{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE RecursiveDo                #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ViewPatterns               #-}
-- |
-- Module: Capnp.Rpc.Untyped
-- Description: Core of the RPC subsystem.
--
-- This module does not deal with schema-level concepts; all capabilities,
-- methods etc. as used here are untyped.
module Capnp.Rpc.Untyped
    (
    -- * Connections to other vats
      ConnConfig(..)
    , handleConn

    -- * Clients for capabilities
    , Client
    , call
    , nullClient
    , newPromiseClient

    , IsClient(..)

    -- * Promise pipelining
    , Pipeline
    , walkPipelinePtr
    , pipelineClient
    , waitPipeline

    -- * Exporting local objects
    , export
    , clientMethodHandler

    -- * Unwrapping local clients
    , unwrapServer

    -- * Waiting for resolution
    , waitClient

    -- * Errors
    , RpcError(..)
    , R.Exception(..)
    , R.Exception'Type(..)

    -- * Shutting down the connection
    ) where

import Control.Concurrent.STM
import Control.Monad.STM.Class
import Control.Monad.Trans.Class
import Data.Word

import Control.Concurrent       (threadDelay)
import Control.Concurrent.Async (concurrently_, race_)
import Control.Concurrent.MVar  (MVar, newEmptyMVar)
import Control.Exception.Safe
    ( Exception
    , MonadThrow
    , SomeException
    , bracket
    , finally
    , fromException
    , throwIO
    , throwM
    , try
    )
import Control.Monad            (forever, void, when)
import Data.Default             (Default(def))
import Data.Foldable            (for_, toList, traverse_)
import Data.Hashable            (Hashable, hash, hashWithSalt)
import Data.Maybe               (catMaybes, fromMaybe)
import Data.String              (fromString)
import Data.Text                (Text)
import Data.Typeable            (Typeable)
import GHC.Generics             (Generic)
import Supervisors              (Supervisor, superviseSTM, withSupervisor)
import System.Mem.StableName    (StableName, hashStableName, makeStableName)
import System.Timeout           (timeout)

import qualified Data.Vector       as V
import qualified Focus
import qualified ListT
import qualified StmContainers.Map as M

import Capnp.Classes        (cerialize, decerialize, fromStruct, new, toStruct)
import Capnp.Convert        (valueToMsg)
import Capnp.Message        (Message, Mutability(..))
import Capnp.Rpc.Errors
    ( eDisconnected
    , eFailed
    , eMethodUnimplemented
    , eUnimplemented
    , wrapException
    )
import Capnp.Rpc.Promise
    (Fulfiller, breakOrFulfill, breakPromise, fulfill, newCallback)
import Capnp.Rpc.Transport  (Transport(recvMsg, sendMsg))
import Capnp.TraversalLimit (LimitT, defaultLimit, evalLimitT)
import Data.Mutable         (thaw)
import Internal.BuildPure   (createPure)
import Internal.Rc          (Rc)
import Internal.SnocList    (SnocList)

import qualified Capnp.Gen.Capnp.Rpc      as RawRpc
import qualified Capnp.Gen.Capnp.Rpc.Pure as R
import qualified Capnp.Message            as Message
import qualified Capnp.Rpc.Server         as Server
import qualified Capnp.Untyped            as UntypedRaw
import qualified Capnp.Untyped.Pure       as Untyped
import qualified Internal.Rc              as Rc
import qualified Internal.SnocList        as SnocList
import qualified Internal.TCloseQ         as TCloseQ
import qualified Lifetimes.Gc             as Fin

-- Note [Organization]
-- ===================
--
-- As much as possible, the logic in this module is centralized according to
-- type types of objects it concerns.
--
-- As an example, consider how we handle embargos: The 'Conn' type's 'embargos'
-- table has values that are just 'Fulfiller's. This allows the code which triggers
-- sending embargoes to have full control over what happens when they return,
-- while the code that routes incoming messages (in 'coordinator') doesn't need
-- to concern itself with the details of embargos -- it just needs to route them
-- to the right place.
--
-- This approach generally results in better separation of concerns.

-- Note [Level 3]
--
-- This is currently a level 1 implementation, so use of most level 3 features
-- results in sending abort messages. However, to make adding this support
-- easier later, we mark such places with a cross-reference back to this note.
--
-- In addition to filling in those spots, the following will need to be dealt
-- with:
--
-- * The "Tribble 4-way Race Condition" as documented in rpc.capnp. This
--   doesn't affect level 1 implementations, but right now we shorten N-hop
--   paths of promises to 1-hop, (calls on Ready PromiseClients just
--   immediately call the target), which is unsafe in a level 3
--   implementation. See the protocol documentation for more info.

-- | We use this type often enough that the types get noisy without a shorthand:
type RawMPtr = Maybe (UntypedRaw.Ptr 'Const)


-- | Errors which can be thrown by the rpc system.
data RpcError
    = ReceivedAbort R.Exception
    -- ^ The remote vat sent us an abort message.
    | SentAbort R.Exception
    -- ^ We sent an abort to the remote vat.
    deriving(Int -> RpcError -> ShowS
[RpcError] -> ShowS
RpcError -> String
(Int -> RpcError -> ShowS)
-> (RpcError -> String) -> ([RpcError] -> ShowS) -> Show RpcError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RpcError] -> ShowS
$cshowList :: [RpcError] -> ShowS
show :: RpcError -> String
$cshow :: RpcError -> String
showsPrec :: Int -> RpcError -> ShowS
$cshowsPrec :: Int -> RpcError -> ShowS
Show, RpcError -> RpcError -> Bool
(RpcError -> RpcError -> Bool)
-> (RpcError -> RpcError -> Bool) -> Eq RpcError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RpcError -> RpcError -> Bool
$c/= :: RpcError -> RpcError -> Bool
== :: RpcError -> RpcError -> Bool
$c== :: RpcError -> RpcError -> Bool
Eq, (forall x. RpcError -> Rep RpcError x)
-> (forall x. Rep RpcError x -> RpcError) -> Generic RpcError
forall x. Rep RpcError x -> RpcError
forall x. RpcError -> Rep RpcError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RpcError x -> RpcError
$cfrom :: forall x. RpcError -> Rep RpcError x
Generic)

makeAbortExn :: Bool -> SomeException -> RpcError
makeAbortExn :: Bool -> SomeException -> RpcError
makeAbortExn Bool
debugMode SomeException
e =
    RpcError -> Maybe RpcError -> RpcError
forall a. a -> Maybe a -> a
fromMaybe
        (Exception -> RpcError
SentAbort (Bool -> SomeException -> Exception
wrapException Bool
debugMode SomeException
e))
        (SomeException -> Maybe RpcError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)

instance Exception RpcError

newtype EmbargoId = EmbargoId { EmbargoId -> Word32
embargoWord :: Word32 } deriving(EmbargoId -> EmbargoId -> Bool
(EmbargoId -> EmbargoId -> Bool)
-> (EmbargoId -> EmbargoId -> Bool) -> Eq EmbargoId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmbargoId -> EmbargoId -> Bool
$c/= :: EmbargoId -> EmbargoId -> Bool
== :: EmbargoId -> EmbargoId -> Bool
$c== :: EmbargoId -> EmbargoId -> Bool
Eq, Int -> EmbargoId -> Int
EmbargoId -> Int
(Int -> EmbargoId -> Int)
-> (EmbargoId -> Int) -> Hashable EmbargoId
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: EmbargoId -> Int
$chash :: EmbargoId -> Int
hashWithSalt :: Int -> EmbargoId -> Int
$chashWithSalt :: Int -> EmbargoId -> Int
Hashable)
newtype QAId = QAId { QAId -> Word32
qaWord :: Word32 } deriving(QAId -> QAId -> Bool
(QAId -> QAId -> Bool) -> (QAId -> QAId -> Bool) -> Eq QAId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QAId -> QAId -> Bool
$c/= :: QAId -> QAId -> Bool
== :: QAId -> QAId -> Bool
$c== :: QAId -> QAId -> Bool
Eq, Int -> QAId -> Int
QAId -> Int
(Int -> QAId -> Int) -> (QAId -> Int) -> Hashable QAId
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: QAId -> Int
$chash :: QAId -> Int
hashWithSalt :: Int -> QAId -> Int
$chashWithSalt :: Int -> QAId -> Int
Hashable)
newtype IEId = IEId { IEId -> Word32
ieWord :: Word32 } deriving(IEId -> IEId -> Bool
(IEId -> IEId -> Bool) -> (IEId -> IEId -> Bool) -> Eq IEId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IEId -> IEId -> Bool
$c/= :: IEId -> IEId -> Bool
== :: IEId -> IEId -> Bool
$c== :: IEId -> IEId -> Bool
Eq, Int -> IEId -> Int
IEId -> Int
(Int -> IEId -> Int) -> (IEId -> Int) -> Hashable IEId
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: IEId -> Int
$chash :: IEId -> Int
hashWithSalt :: Int -> IEId -> Int
$chashWithSalt :: Int -> IEId -> Int
Hashable)

-- We define these to just show the number; the derived instances would include
-- data constructors, which is a bit weird since these show up in output that
-- is sometimes shown to users.
instance Show QAId where
    show :: QAId -> String
show = Word32 -> String
forall a. Show a => a -> String
show (Word32 -> String) -> (QAId -> Word32) -> QAId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QAId -> Word32
qaWord
instance Show IEId where
    show :: IEId -> String
show = Word32 -> String
forall a. Show a => a -> String
show (Word32 -> String) -> (IEId -> Word32) -> IEId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEId -> Word32
ieWord

-- | A connection to a remote vat
data Conn = Conn
    { Conn -> StableName (MVar ())
stableName :: StableName (MVar ())
    -- So we can use the connection as a map key. The MVar used to create
    -- this is just an arbitrary value; the only property we care about
    -- is that it is distinct for each 'Conn', so we use something with
    -- reference semantics to guarantee this.

    , Conn -> Bool
debugMode  :: !Bool
    -- whether to include extra (possibly sensitive) info in error messages.

    , Conn -> TVar LiveState
liveState  :: TVar LiveState
    }

data LiveState
    = Live Conn'
    | Dead

data Conn' = Conn'
    { Conn' -> TBQueue (Message 'Const)
sendQ            :: TBQueue (Message 'Const)
    , Conn' -> TBQueue (Message 'Const)
recvQ            :: TBQueue (Message 'Const)
    -- queues of messages to send and receive; each of these has a dedicated
    -- thread doing the IO (see 'sendLoop' and 'recvLoop'):

    , Conn' -> Supervisor
supervisor       :: Supervisor
    -- Supervisor managing the lifetimes of threads bound to this connection.

    , Conn' -> IdPool
questionIdPool   :: IdPool
    , Conn' -> IdPool
exportIdPool     :: IdPool
    -- Pools of identifiers for new questions and exports

    , Conn' -> Map QAId EntryQA
questions        :: M.Map QAId EntryQA
    , Conn' -> Map QAId EntryQA
answers          :: M.Map QAId EntryQA
    , Conn' -> Map IEId EntryE
exports          :: M.Map IEId EntryE
    , Conn' -> Map IEId EntryI
imports          :: M.Map IEId EntryI

    , Conn' -> Map EmbargoId (Fulfiller ())
embargos         :: M.Map EmbargoId (Fulfiller ())
    -- Outstanding embargos. When we receive a 'Disembargo' message with its
    -- context field set to receiverLoopback, we look up the embargo id in
    -- this table, and fulfill the promise.

    , Conn' -> TQueue (IO ())
pendingCallbacks :: TQueue (IO ())
    -- See Note [callbacks]

    , Conn' -> Maybe Client
bootstrap        :: Maybe Client
    -- The capability which should be served as this connection's bootstrap
    -- interface (if any).
    }

instance Eq Conn where
    Conn
x == :: Conn -> Conn -> Bool
== Conn
y = Conn -> StableName (MVar ())
stableName Conn
x StableName (MVar ()) -> StableName (MVar ()) -> Bool
forall a. Eq a => a -> a -> Bool
== Conn -> StableName (MVar ())
stableName Conn
y

instance Hashable Conn where
    hash :: Conn -> Int
hash Conn{StableName (MVar ())
stableName :: StableName (MVar ())
$sel:stableName:Conn :: Conn -> StableName (MVar ())
stableName} = StableName (MVar ()) -> Int
forall a. StableName a -> Int
hashStableName StableName (MVar ())
stableName
    hashWithSalt :: Int -> Conn -> Int
hashWithSalt Int
_ = Conn -> Int
forall a. Hashable a => a -> Int
hash

-- | Configuration information for a connection.
data ConnConfig = ConnConfig
    { ConnConfig -> Word32
maxQuestions  :: !Word32
    -- ^ The maximum number of simultanious outstanding requests to the peer
    -- vat. Once this limit is reached, further questsions will block until
    -- some of the existing questions have been answered.
    --
    -- Defaults to 128.

    , ConnConfig -> Word32
maxExports    :: !Word32
    -- ^ The maximum number of objects which may be exported on this connection.
    --
    -- Defaults to 8192.

    , ConnConfig -> Bool
debugMode     :: !Bool
    -- ^ In debug mode, errors reported by the RPC system to its peers will
    -- contain extra information. This should not be used in production, as
    -- it is possible for these messages to contain sensitive information,
    -- but it can be useful for debugging.
    --
    -- Defaults to 'False'.

    , ConnConfig -> Supervisor -> STM (Maybe Client)
getBootstrap  :: Supervisor -> STM (Maybe Client)
    -- ^ Get the bootstrap interface we should serve for this connection.
    -- the argument is a supervisor whose lifetime is bound to the
    -- connection. If 'getBootstrap' returns 'Nothing', we will respond
    -- to bootstrap messages with an exception.
    --
    -- The default always returns 'Nothing'.
    --
    -- 'getBootstrap' MUST NOT block; the connection will not be serviced
    -- and 'withBootstrap' will not be run until this returns. If you need
    -- to supply the bootstrap interface later, use 'newPromiseClient'.

    , ConnConfig -> Maybe (Supervisor -> Client -> IO ())
withBootstrap :: Maybe (Supervisor -> Client -> IO ())
    -- ^ An action to perform with access to the remote vat's bootstrap
    -- interface. The supervisor argument is bound to the lifetime of the
    -- connection. If this is 'Nothing' (the default), the bootstrap
    -- interface will not be requested.
    }

instance Default ConnConfig where
    def :: ConnConfig
def = ConnConfig :: Word32
-> Word32
-> Bool
-> (Supervisor -> STM (Maybe Client))
-> Maybe (Supervisor -> Client -> IO ())
-> ConnConfig
ConnConfig
        { $sel:maxQuestions:ConnConfig :: Word32
maxQuestions   = Word32
128
        , $sel:maxExports:ConnConfig :: Word32
maxExports     = Word32
8192
        , $sel:debugMode:ConnConfig :: Bool
debugMode      = Bool
False
        , $sel:getBootstrap:ConnConfig :: Supervisor -> STM (Maybe Client)
getBootstrap   = \Supervisor
_ -> Maybe Client -> STM (Maybe Client)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Client
forall a. Maybe a
Nothing
        , $sel:withBootstrap:ConnConfig :: Maybe (Supervisor -> Client -> IO ())
withBootstrap  = Maybe (Supervisor -> Client -> IO ())
forall a. Maybe a
Nothing
        }

-- | Queue an IO action to be run some time after this transaction commits.
-- See Note [callbacks].
queueIO :: Conn' -> IO () -> STM ()
queueIO :: Conn' -> IO () -> STM ()
queueIO Conn'{TQueue (IO ())
pendingCallbacks :: TQueue (IO ())
$sel:pendingCallbacks:Conn' :: Conn' -> TQueue (IO ())
pendingCallbacks} = TQueue (IO ()) -> IO () -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (IO ())
pendingCallbacks

-- | Queue another transaction to be run some time after this transaction
-- commits, in a thread bound to the lifetime of the connection. If this is
-- called multiple times within the same transaction, each of the
-- transactions will be run separately, in the order they were queued.
--
-- See Note [callbacks]
queueSTM :: Conn' -> STM () -> STM ()
queueSTM :: Conn' -> STM () -> STM ()
queueSTM Conn'
conn = Conn' -> IO () -> STM ()
queueIO Conn'
conn (IO () -> STM ()) -> (STM () -> IO ()) -> STM () -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically

-- | @'mapQueueSTM' conn fs val@ queues the list of transactions obtained
-- by applying each element of @fs@ to @val@.
mapQueueSTM :: Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM :: Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM Conn'
conn SnocList (a -> STM ())
fs a
x = ((a -> STM ()) -> STM ()) -> SnocList (a -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\a -> STM ()
f -> Conn' -> STM () -> STM ()
queueSTM Conn'
conn (a -> STM ()
f a
x)) SnocList (a -> STM ())
fs

-- Note [callbacks]
-- ================
--
-- There are many places where we want to register some code to run after
-- some later event has happened -- for exmaple:
--
-- * We send a Call to the remote vat, and when a corresponding Return message
--   is received, we want to fulfill (or break) the local promise for the
--   result.
-- * We send a Disembargo (with senderLoopback set), and want to actually lift
--   the embargo when the corresponding (receiverLoopback) message arrives.
--
-- Keeping the two parts of these patterns together tends to result in better
-- separation of concerns, and is easier to maintain.
--
-- To achieve this, the four tables and other connection state have fields in
-- which callbacks can be registered -- for example, an outstanding question has
-- fields containing transactions to run when the return and/or finish messages
-- arrive.
--
-- When it is time to actually run these, we want to make sure that each of them
-- runs as their own transaction. If, for example, when registering a callback to
-- run when a return message is received, we find that the return message is
-- already available, it might be tempting to just run the transaction immediately.
-- But this means that the synchronization semantics are totally different from the
-- case where the callback really does get run later!
--
-- In addition, we sometimes want to register a finalizer inside a transaction,
-- but this can only be done in IO.
--
-- To solve these issues, the connection maintains a queue of all callback actions
-- that are ready to run, and when the event a callback is waiting for occurs, we
-- simply move the callback to the queue, using 'queueIO' or 'queueSTM'. When the
-- connection starts up, it creates a thread running 'callbacksLoop', which just
-- continually flushes the queue, running the actions in the queue.

-- | Get a new question id. retries if we are out of available question ids.
newQuestion :: Conn' -> STM QAId
newQuestion :: Conn' -> STM QAId
newQuestion = (Word32 -> QAId) -> STM Word32 -> STM QAId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> QAId
QAId (STM Word32 -> STM QAId)
-> (Conn' -> STM Word32) -> Conn' -> STM QAId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdPool -> STM Word32
newId (IdPool -> STM Word32) -> (Conn' -> IdPool) -> Conn' -> STM Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn' -> IdPool
questionIdPool

-- | Return a question id to the pool of available ids.
freeQuestion :: Conn' -> QAId -> STM ()
freeQuestion :: Conn' -> QAId -> STM ()
freeQuestion Conn'
conn = IdPool -> Word32 -> STM ()
freeId (Conn' -> IdPool
questionIdPool Conn'
conn) (Word32 -> STM ()) -> (QAId -> Word32) -> QAId -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QAId -> Word32
qaWord

-- | Get a new export id. retries if we are out of available export ids.
newExport :: Conn' -> STM IEId
newExport :: Conn' -> STM IEId
newExport = (Word32 -> IEId) -> STM Word32 -> STM IEId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> IEId
IEId (STM Word32 -> STM IEId)
-> (Conn' -> STM Word32) -> Conn' -> STM IEId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdPool -> STM Word32
newId (IdPool -> STM Word32) -> (Conn' -> IdPool) -> Conn' -> STM Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn' -> IdPool
exportIdPool

-- | Return a export id to the pool of available ids.
freeExport :: Conn' -> IEId -> STM ()
freeExport :: Conn' -> IEId -> STM ()
freeExport Conn'
conn = IdPool -> Word32 -> STM ()
freeId (Conn' -> IdPool
exportIdPool Conn'
conn) (Word32 -> STM ()) -> (IEId -> Word32) -> IEId -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEId -> Word32
ieWord

-- | Get a new embargo id. This shares the same pool as questions.
newEmbargo :: Conn' -> STM EmbargoId
newEmbargo :: Conn' -> STM EmbargoId
newEmbargo = (Word32 -> EmbargoId) -> STM Word32 -> STM EmbargoId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> EmbargoId
EmbargoId (STM Word32 -> STM EmbargoId)
-> (Conn' -> STM Word32) -> Conn' -> STM EmbargoId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdPool -> STM Word32
newId (IdPool -> STM Word32) -> (Conn' -> IdPool) -> Conn' -> STM Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn' -> IdPool
questionIdPool

-- | Return an embargo id. to the available pool.
freeEmbargo :: Conn' -> EmbargoId -> STM ()
freeEmbargo :: Conn' -> EmbargoId -> STM ()
freeEmbargo Conn'
conn = IdPool -> Word32 -> STM ()
freeId (Conn' -> IdPool
exportIdPool Conn'
conn) (Word32 -> STM ()) -> (EmbargoId -> Word32) -> EmbargoId -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmbargoId -> Word32
embargoWord

-- | Handle a connection to another vat. Returns when the connection is closed.
handleConn :: Transport -> ConnConfig -> IO ()
handleConn :: Transport -> ConnConfig -> IO ()
handleConn
    Transport
transport
    cfg :: ConnConfig
cfg@ConnConfig
        { Word32
maxQuestions :: Word32
$sel:maxQuestions:ConnConfig :: ConnConfig -> Word32
maxQuestions
        , Word32
maxExports :: Word32
$sel:maxExports:ConnConfig :: ConnConfig -> Word32
maxExports
        , Maybe (Supervisor -> Client -> IO ())
withBootstrap :: Maybe (Supervisor -> Client -> IO ())
$sel:withBootstrap:ConnConfig :: ConnConfig -> Maybe (Supervisor -> Client -> IO ())
withBootstrap
        , Bool
debugMode :: Bool
$sel:debugMode:ConnConfig :: ConnConfig -> Bool
debugMode
        }
    = (Supervisor -> IO ()) -> IO ()
forall a. (Supervisor -> IO a) -> IO a
withSupervisor ((Supervisor -> IO ()) -> IO ()) -> (Supervisor -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Supervisor
sup ->
        IO (Conn, Conn')
-> ((Conn, Conn') -> IO ()) -> ((Conn, Conn') -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
            (Supervisor -> IO (Conn, Conn')
newConn Supervisor
sup)
            (Conn, Conn') -> IO ()
stopConn
            (Conn, Conn') -> IO ()
runConn
  where
    newConn :: Supervisor -> IO (Conn, Conn')
newConn Supervisor
sup = do
        StableName (MVar ())
stableName <- MVar () -> IO (StableName (MVar ()))
forall a. a -> IO (StableName a)
makeStableName (MVar () -> IO (StableName (MVar ())))
-> IO (MVar ()) -> IO (StableName (MVar ()))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
        STM (Conn, Conn') -> IO (Conn, Conn')
forall a. STM a -> IO a
atomically (STM (Conn, Conn') -> IO (Conn, Conn'))
-> STM (Conn, Conn') -> IO (Conn, Conn')
forall a b. (a -> b) -> a -> b
$ do
            Maybe Client
bootstrap <- ConnConfig -> Supervisor -> STM (Maybe Client)
getBootstrap ConnConfig
cfg Supervisor
sup
            IdPool
questionIdPool <- Word32 -> STM IdPool
newIdPool Word32
maxQuestions
            IdPool
exportIdPool <- Word32 -> STM IdPool
newIdPool Word32
maxExports

            TBQueue (Message 'Const)
sendQ <- Natural -> STM (TBQueue (Message 'Const))
forall a. Natural -> STM (TBQueue a)
newTBQueue (Natural -> STM (TBQueue (Message 'Const)))
-> Natural -> STM (TBQueue (Message 'Const))
forall a b. (a -> b) -> a -> b
$ Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
maxQuestions
            TBQueue (Message 'Const)
recvQ <- Natural -> STM (TBQueue (Message 'Const))
forall a. Natural -> STM (TBQueue a)
newTBQueue (Natural -> STM (TBQueue (Message 'Const)))
-> Natural -> STM (TBQueue (Message 'Const))
forall a b. (a -> b) -> a -> b
$ Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
maxQuestions

            Map QAId EntryQA
questions <- STM (Map QAId EntryQA)
forall key value. STM (Map key value)
M.new
            Map QAId EntryQA
answers <- STM (Map QAId EntryQA)
forall key value. STM (Map key value)
M.new
            Map IEId EntryE
exports <- STM (Map IEId EntryE)
forall key value. STM (Map key value)
M.new
            Map IEId EntryI
imports <- STM (Map IEId EntryI)
forall key value. STM (Map key value)
M.new

            Map EmbargoId (Fulfiller ())
embargos <- STM (Map EmbargoId (Fulfiller ()))
forall key value. STM (Map key value)
M.new
            TQueue (IO ())
pendingCallbacks <- STM (TQueue (IO ()))
forall a. STM (TQueue a)
newTQueue

            let conn' :: Conn'
conn' = Conn' :: TBQueue (Message 'Const)
-> TBQueue (Message 'Const)
-> Supervisor
-> IdPool
-> IdPool
-> Map QAId EntryQA
-> Map QAId EntryQA
-> Map IEId EntryE
-> Map IEId EntryI
-> Map EmbargoId (Fulfiller ())
-> TQueue (IO ())
-> Maybe Client
-> Conn'
Conn'
                    { $sel:supervisor:Conn' :: Supervisor
supervisor = Supervisor
sup
                    , IdPool
questionIdPool :: IdPool
$sel:questionIdPool:Conn' :: IdPool
questionIdPool
                    , IdPool
exportIdPool :: IdPool
$sel:exportIdPool:Conn' :: IdPool
exportIdPool
                    , TBQueue (Message 'Const)
recvQ :: TBQueue (Message 'Const)
$sel:recvQ:Conn' :: TBQueue (Message 'Const)
recvQ
                    , TBQueue (Message 'Const)
sendQ :: TBQueue (Message 'Const)
$sel:sendQ:Conn' :: TBQueue (Message 'Const)
sendQ
                    , Map QAId EntryQA
questions :: Map QAId EntryQA
$sel:questions:Conn' :: Map QAId EntryQA
questions
                    , Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Map QAId EntryQA
answers
                    , Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Map IEId EntryE
exports
                    , Map IEId EntryI
imports :: Map IEId EntryI
$sel:imports:Conn' :: Map IEId EntryI
imports
                    , Map EmbargoId (Fulfiller ())
embargos :: Map EmbargoId (Fulfiller ())
$sel:embargos:Conn' :: Map EmbargoId (Fulfiller ())
embargos
                    , TQueue (IO ())
pendingCallbacks :: TQueue (IO ())
$sel:pendingCallbacks:Conn' :: TQueue (IO ())
pendingCallbacks
                    , Maybe Client
bootstrap :: Maybe Client
$sel:bootstrap:Conn' :: Maybe Client
bootstrap
                    }
            TVar LiveState
liveState <- LiveState -> STM (TVar LiveState)
forall a. a -> STM (TVar a)
newTVar (Conn' -> LiveState
Live Conn'
conn')
            let conn :: Conn
conn = Conn :: StableName (MVar ()) -> Bool -> TVar LiveState -> Conn
Conn
                    { StableName (MVar ())
stableName :: StableName (MVar ())
$sel:stableName:Conn :: StableName (MVar ())
stableName
                    , Bool
debugMode :: Bool
$sel:debugMode:Conn :: Bool
debugMode
                    , TVar LiveState
liveState :: TVar LiveState
$sel:liveState:Conn :: TVar LiveState
liveState
                    }
            (Conn, Conn') -> STM (Conn, Conn')
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Conn
conn, Conn'
conn')
    runConn :: (Conn, Conn') -> IO ()
runConn (Conn
conn, Conn'
conn') = do
        Either RpcError ()
result <- IO () -> IO (Either RpcError ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO () -> IO (Either RpcError ()))
-> IO () -> IO (Either RpcError ())
forall a b. (a -> b) -> a -> b
$
            ( Conn -> IO ()
coordinator Conn
conn
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
`concurrently_` Transport -> Conn' -> IO ()
sendLoop Transport
transport Conn'
conn'
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
`concurrently_` Transport -> Conn' -> IO ()
recvLoop Transport
transport Conn'
conn'
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
`concurrently_` Conn' -> IO ()
callbacksLoop Conn'
conn'
            ) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
`race_`
                Conn -> Conn' -> IO ()
useBootstrap Conn
conn Conn'
conn'
        case Either RpcError ()
result of
            Left (SentAbort Exception
e) -> do
                -- We need to actually send it:
                Message 'Const
rawMsg <- WordCount
-> (forall s. PureBuilder s (Mutable s (Message 'Const)))
-> IO (Message 'Const)
forall (m :: * -> *) a.
(MonadThrow m, Thaw a) =>
WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure WordCount
forall a. Bounded a => a
maxBound ((forall s. PureBuilder s (Mutable s (Message 'Const)))
 -> IO (Message 'Const))
-> (forall s. PureBuilder s (Mutable s (Message 'Const)))
-> IO (Message 'Const)
forall a b. (a -> b) -> a -> b
$ Message -> PureBuilder s (Message ('Mut s))
forall (m :: * -> *) s a.
(MonadLimit m, WriteCtx m s, Cerialize s a,
 ToStruct ('Mut s) (Cerial ('Mut s) a)) =>
a -> m (Message ('Mut s))
valueToMsg (Message -> PureBuilder s (Message ('Mut s)))
-> Message -> PureBuilder s (Message ('Mut s))
forall a b. (a -> b) -> a -> b
$ Exception -> Message
R.Message'abort Exception
e
                IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
1000000 (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Transport -> Message 'Const -> IO ()
sendMsg Transport
transport Message 'Const
rawMsg
                RpcError -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (RpcError -> IO ()) -> RpcError -> IO ()
forall a b. (a -> b) -> a -> b
$ Exception -> RpcError
SentAbort Exception
e
            Left RpcError
e ->
                RpcError -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO RpcError
e
            Right ()
_ ->
                () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    stopConn :: (Conn, Conn') -> IO ()
stopConn
            ( conn :: Conn
conn@Conn{TVar LiveState
liveState :: TVar LiveState
$sel:liveState:Conn :: Conn -> TVar LiveState
liveState}
            , conn' :: Conn'
conn'@Conn'{Map QAId EntryQA
questions :: Map QAId EntryQA
$sel:questions:Conn' :: Conn' -> Map QAId EntryQA
questions, Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports, Map EmbargoId (Fulfiller ())
embargos :: Map EmbargoId (Fulfiller ())
$sel:embargos:Conn' :: Conn' -> Map EmbargoId (Fulfiller ())
embargos}
            ) = do
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let walk :: Map key value -> ((key, value) -> STM ()) -> STM ()
walk Map key value
table = (((key, value) -> STM ()) -> ListT STM (key, value) -> STM ())
-> ListT STM (key, value) -> ((key, value) -> STM ()) -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((key, value) -> STM ()) -> ListT STM (key, value) -> STM ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> ListT m a -> m ()
ListT.traverse_ (Map key value -> ListT STM (key, value)
forall key value. Map key value -> ListT STM (key, value)
M.listT Map key value
table)
            -- drop the bootstrap interface:
            case Conn' -> Maybe Client
bootstrap Conn'
conn' of
                Just (Client (Just Client'
client')) -> Conn -> Client' -> STM ()
dropConnExport Conn
conn Client'
client'
                Maybe Client
_                            -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            -- Remove everything from the exports table:
            Map IEId EntryE -> ((IEId, EntryE) -> STM ()) -> STM ()
forall key value.
Map key value -> ((key, value) -> STM ()) -> STM ()
walk Map IEId EntryE
exports (((IEId, EntryE) -> STM ()) -> STM ())
-> ((IEId, EntryE) -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(IEId
_, EntryE{Client'
$sel:client:EntryE :: EntryE -> Client'
client :: Client'
client}) ->
                Conn -> Client' -> STM ()
dropConnExport Conn
conn Client'
client
            -- Outstanding questions should all throw disconnected:
            Map QAId EntryQA -> ((QAId, EntryQA) -> STM ()) -> STM ()
forall key value.
Map key value -> ((key, value) -> STM ()) -> STM ()
walk Map QAId EntryQA
questions (((QAId, EntryQA) -> STM ()) -> STM ())
-> ((QAId, EntryQA) -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(QAId
qid, EntryQA
entry) ->
                let raiseDisconnected :: SnocList (Return -> STM ()) -> STM ()
raiseDisconnected SnocList (Return -> STM ())
onReturn =
                        Conn' -> SnocList (Return -> STM ()) -> Return -> STM ()
forall a. Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM Conn'
conn' SnocList (Return -> STM ())
onReturn (Return -> STM ()) -> Return -> STM ()
forall a b. (a -> b) -> a -> b
$ Return :: QAId -> Bool -> Return' -> Return
Return
                            { $sel:answerId:Return :: QAId
answerId = QAId
qid
                            , $sel:releaseParamCaps:Return :: Bool
releaseParamCaps = Bool
False
                            , $sel:union':Return :: Return'
union' = Exception -> Return'
Return'exception Exception
eDisconnected
                            }
                in case EntryQA
entry of
                    NewQA{SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
onReturn}      -> SnocList (Return -> STM ()) -> STM ()
raiseDisconnected SnocList (Return -> STM ())
onReturn
                    HaveFinish{SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} -> SnocList (Return -> STM ()) -> STM ()
raiseDisconnected SnocList (Return -> STM ())
onReturn
                    EntryQA
_                    -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            -- same thing with embargos:
            Map EmbargoId (Fulfiller ())
-> ((EmbargoId, Fulfiller ()) -> STM ()) -> STM ()
forall key value.
Map key value -> ((key, value) -> STM ()) -> STM ()
walk Map EmbargoId (Fulfiller ())
embargos (((EmbargoId, Fulfiller ()) -> STM ()) -> STM ())
-> ((EmbargoId, Fulfiller ()) -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(EmbargoId
_, Fulfiller ()
fulfiller) ->
                Fulfiller () -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller ()
fulfiller Exception
eDisconnected
            -- mark the connection as dead, making the live state inaccessible:
            TVar LiveState -> LiveState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar LiveState
liveState LiveState
Dead
        -- Make sure any pending callbacks get run. This is important, since
        -- some of these do things like raise disconnected exceptions.
        --
        -- FIXME: there's a race condition that we're not dealing with:
        -- if the callbacks loop is killed between dequeuing an action and
        -- performing it that action will be lost.
        Conn' -> IO ()
flushCallbacks Conn'
conn'
    useBootstrap :: Conn -> Conn' -> IO ()
useBootstrap Conn
conn Conn'
conn' = case Maybe (Supervisor -> Client -> IO ())
withBootstrap of
        Maybe (Supervisor -> Client -> IO ())
Nothing ->
            IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
        Just Supervisor -> Client -> IO ()
f  ->
            STM Client -> IO Client
forall a. STM a -> IO a
atomically (Conn -> STM Client
requestBootstrap Conn
conn) IO Client -> (Client -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Supervisor -> Client -> IO ()
f (Conn' -> Supervisor
supervisor Conn'
conn')


-- | A pool of ids; used when choosing identifiers for questions and exports.
newtype IdPool = IdPool (TVar [Word32])

-- | @'newIdPool' size@ creates a new pool of ids, with @size@ available ids.
newIdPool :: Word32 -> STM IdPool
newIdPool :: Word32 -> STM IdPool
newIdPool Word32
size = TVar [Word32] -> IdPool
IdPool (TVar [Word32] -> IdPool) -> STM (TVar [Word32]) -> STM IdPool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word32] -> STM (TVar [Word32])
forall a. a -> STM (TVar a)
newTVar [Word32
0..Word32
sizeWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
1]

-- | Get a new id from the pool. Retries if the pool is empty.
newId :: IdPool -> STM Word32
newId :: IdPool -> STM Word32
newId (IdPool TVar [Word32]
pool) = TVar [Word32] -> STM [Word32]
forall a. TVar a -> STM a
readTVar TVar [Word32]
pool STM [Word32] -> ([Word32] -> STM Word32) -> STM Word32
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> STM Word32
forall a. STM a
retry
    (Word32
id:[Word32]
ids) -> do
        TVar [Word32] -> [Word32] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [Word32]
pool ([Word32] -> STM ()) -> [Word32] -> STM ()
forall a b. (a -> b) -> a -> b
$! [Word32]
ids
        Word32 -> STM Word32
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
id

-- | Return an id to the pool.
freeId :: IdPool -> Word32 -> STM ()
freeId :: IdPool -> Word32 -> STM ()
freeId (IdPool TVar [Word32]
pool) Word32
id = TVar [Word32] -> ([Word32] -> [Word32]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Word32]
pool (Word32
idWord32 -> [Word32] -> [Word32]
forall a. a -> [a] -> [a]
:)

-- | An entry in our questions or answers table.
data EntryQA
    -- | An entry for which we have neither sent/received a finish, nor
    -- a return. Contains two sets of callbacks, to invoke on each type
    -- of message.
    = NewQA
        { EntryQA -> SnocList (Finish -> STM ())
onFinish :: SnocList (R.Finish -> STM ())
        , EntryQA -> SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
        }
    -- | An entry for which we've sent/received a return, but not a finish.
    -- Contains the return message, and a set of callbacks to invoke on the
    -- finish.
    | HaveReturn
        { EntryQA -> Return
returnMsg :: Return
        , onFinish  :: SnocList (R.Finish -> STM ())
        }
    -- | An entry for which we've sent/received a finish, but not a return.
    -- Contains the finish message, and a set of callbacks to invoke on the
    -- return.
    | HaveFinish
        { EntryQA -> Finish
finishMsg :: R.Finish
        , onReturn  :: SnocList (Return -> STM ())
        }


-- | An entry in our imports table.
data EntryI = EntryI
    { EntryI -> Rc ()
localRc      :: Rc ()
    -- ^ A refcount cell with a finalizer attached to it; when the finalizer
    -- runs it will remove this entry from the table and send a release
    -- message to the remote vat.
    , EntryI -> Word32
remoteRc     :: !Word32
    -- ^ The reference count for this object as understood by the remote
    -- vat. This tells us what to send in the release message's count field.
    , EntryI -> ExportMap
proxies      :: ExportMap
    -- ^ See Note [proxies]
    --
    , EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState :: Maybe
        ( TVar PromiseState
        , TmpDest -- origTarget field. TODO(cleanup): clean this up a bit.
        )
    -- ^ If this entry is a promise, this will contain the state of that
    -- promise, so that it may be used to create PromiseClients and
    -- update the promise when it resolves.
    }

-- | An entry in our exports table.
data EntryE = EntryE
    { EntryE -> Client'
client   :: Client'
    -- ^ The client. We cache it in the table so there's only one object
    -- floating around, which lets us attach a finalizer without worrying
    -- about it being run more than once.
    , EntryE -> Word32
refCount :: !Word32
    -- ^ The refcount for this entry. This lets us know when we can drop
    -- the entry from the table.
    }

-- | Types which may be converted to and from 'Client's. Typically these
-- will be simple type wrappers for capabilities.
class IsClient a where
    -- | Convert a value to a client.
    toClient :: a -> Client
    -- | Convert a client to a value.
    fromClient :: Client -> a

instance IsClient Client where
    toClient :: Client -> Client
toClient = Client -> Client
forall a. a -> a
id
    fromClient :: Client -> Client
fromClient = Client -> Client
forall a. a -> a
id

instance Show Client where
    show :: Client -> String
show (Client Maybe Client'
Nothing) = String
"nullClient"
    show Client
_                = String
"({- capability; not statically representable -})"

-- | A reference to a capability, which may be live either in the current vat
-- or elsewhere. Holding a client affords making method calls on a capability
-- or modifying the local vat's reference count to it.
newtype Client =
    -- We wrap the real client in a Maybe, with Nothing representing a 'null'
    -- capability.
    Client (Maybe Client')
    deriving(Client -> Client -> Bool
(Client -> Client -> Bool)
-> (Client -> Client -> Bool) -> Eq Client
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Client -> Client -> Bool
$c/= :: Client -> Client -> Bool
== :: Client -> Client -> Bool
$c== :: Client -> Client -> Bool
Eq)

-- | A non-null client.
data Client'
    -- | A client pointing at a capability local to our own vat.
    = LocalClient
        { Client' -> ExportMap
exportMap    :: ExportMap
        -- ^ Record of what export IDs this client has on different remote
        -- connections.
        , Client' -> Rc (CallInfo -> STM ())
qCall        :: Rc (Server.CallInfo -> STM ())
        -- ^ Queue a call for the local capability to handle. This is wrapped
        -- in a reference counted cell, whose finalizer stops the server.
        , Client' -> Cell ()
finalizerKey :: Fin.Cell ()
        -- ^ Finalizer key; when this is collected, qCall will be released.
        , Client' -> forall a. Typeable a => Maybe a
unwrapper    :: forall a. Typeable a => Maybe a
        }
    -- | A client which will resolve to some other capability at
    -- some point.
    | PromiseClient
        { Client' -> TVar PromiseState
pState     :: TVar PromiseState
        -- ^ The current state of the promise; the indirection allows
        -- the promise to be updated.
        , exportMap  :: ExportMap

        , Client' -> TmpDest
origTarget :: TmpDest
        -- ^ The original target of this promise, before it was resolved.
        -- (if it is still in the pending state, it will match the TmpDest
        -- stored there).
        --
        -- FIXME: if this is an ImportDest, by holding on to this we actually
        -- leak the cap.
        }
    -- | A client which points to a (resolved) capability in a remote vat.
    | ImportClient (Fin.Cell ImportRef)

-- | A 'Pipeline' is a reference to a value within a message that has not yet arrived.
data Pipeline = Pipeline
    { Pipeline -> TVar PipelineState
state :: TVar PipelineState
    , Pipeline -> SnocList Word16
steps :: SnocList Word16
    }

data PipelineState
    = PendingRemotePipeline
        { PipelineState -> QAId
answerId  :: !QAId
        , PipelineState -> Map (SnocList Word16) Client
clientMap :: M.Map (SnocList Word16) Client
        , PipelineState -> Conn
conn      :: Conn
        }
    | PendingLocalPipeline (SnocList (Fulfiller RawMPtr))
    | ReadyPipeline (Either R.Exception RawMPtr)

-- | 'walkPipleinePtr' follows a pointer starting from the object referred to by the
-- 'Pipeline'. The 'Pipeline' must refer to a struct, and the pointer is referred to
-- by its index into the struct's pointer section.
walkPipelinePtr :: Pipeline -> Word16 -> Pipeline
walkPipelinePtr :: Pipeline -> Word16 -> Pipeline
walkPipelinePtr p :: Pipeline
p@Pipeline{SnocList Word16
steps :: SnocList Word16
$sel:steps:Pipeline :: Pipeline -> SnocList Word16
steps} Word16
step =
    Pipeline
p { $sel:steps:Pipeline :: SnocList Word16
steps = SnocList Word16 -> Word16 -> SnocList Word16
forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList Word16
steps Word16
step }

-- | Convert a 'Pipeline' into a 'Client', which can be used to send messages to the
-- referant of the 'Pipeline', using promise pipelining.
pipelineClient :: MonadSTM m => Pipeline -> m Client
pipelineClient :: Pipeline -> m Client
pipelineClient Pipeline{TVar PipelineState
state :: TVar PipelineState
$sel:state:Pipeline :: Pipeline -> TVar PipelineState
state, SnocList Word16
steps :: SnocList Word16
$sel:steps:Pipeline :: Pipeline -> SnocList Word16
steps} = STM Client -> m Client
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM Client -> m Client) -> STM Client -> m Client
forall a b. (a -> b) -> a -> b
$ do
    TVar PipelineState -> STM PipelineState
forall a. TVar a -> STM a
readTVar TVar PipelineState
state STM PipelineState -> (PipelineState -> STM Client) -> STM Client
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        PendingRemotePipeline{QAId
answerId :: QAId
$sel:answerId:PendingRemotePipeline :: PipelineState -> QAId
answerId, Map (SnocList Word16) Client
clientMap :: Map (SnocList Word16) Client
$sel:clientMap:PendingRemotePipeline :: PipelineState -> Map (SnocList Word16) Client
clientMap, Conn
conn :: Conn
$sel:conn:PendingRemotePipeline :: PipelineState -> Conn
conn} -> do
            Maybe Client
maybeClient <- SnocList Word16
-> Map (SnocList Word16) Client -> STM (Maybe Client)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup SnocList Word16
steps Map (SnocList Word16) Client
clientMap
            case Maybe Client
maybeClient of
                Maybe Client
Nothing -> do
                    Client
client <- Conn -> PromisedAnswer -> STM Client
promisedAnswerClient
                        Conn
conn
                        PromisedAnswer :: QAId -> SnocList Word16 -> PromisedAnswer
PromisedAnswer { QAId
$sel:answerId:PromisedAnswer :: QAId
answerId :: QAId
answerId, $sel:transform:PromisedAnswer :: SnocList Word16
transform = SnocList Word16
steps }
                    Client -> SnocList Word16 -> Map (SnocList Word16) Client -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert Client
client SnocList Word16
steps Map (SnocList Word16) Client
clientMap
                    Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
client
                Just Client
client ->
                    Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
client
        PendingLocalPipeline SnocList (Fulfiller RawMPtr)
subscribers -> do
            (Client
ret, Fulfiller Client
retFulfiller) <- STM (Client, Fulfiller Client)
forall (m :: * -> *) c.
(MonadSTM m, IsClient c) =>
m (c, Fulfiller c)
newPromiseClient
            Fulfiller RawMPtr
ptrFulfiller <- (Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr)
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr))
-> (Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr)
forall a b. (a -> b) -> a -> b
$ \Either Exception RawMPtr
r -> do
                TVar PipelineState -> PipelineState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
state (Either Exception RawMPtr -> PipelineState
ReadyPipeline Either Exception RawMPtr
r)
                case Either Exception RawMPtr
r of
                    Left Exception
e ->
                        Fulfiller Client -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller Client
retFulfiller Exception
e
                    Right RawMPtr
v ->
                        ([Word16] -> RawMPtr -> STM Client
forall (m :: * -> *).
MonadThrow m =>
[Word16] -> RawMPtr -> m Client
ptrPathClient (SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
steps) RawMPtr
v  STM Client -> (Client -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fulfiller Client -> Client -> STM ()
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller Client
retFulfiller)
                            STM () -> (SomeException -> STM ()) -> STM ()
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
`catchSTM`
                            (Fulfiller Client -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller Client
retFulfiller (Exception -> STM ())
-> (SomeException -> Exception) -> SomeException -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SomeException -> Exception
wrapException Bool
False)
            TVar PipelineState -> PipelineState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
state (PipelineState -> STM ()) -> PipelineState -> STM ()
forall a b. (a -> b) -> a -> b
$ SnocList (Fulfiller RawMPtr) -> PipelineState
PendingLocalPipeline (SnocList (Fulfiller RawMPtr) -> PipelineState)
-> SnocList (Fulfiller RawMPtr) -> PipelineState
forall a b. (a -> b) -> a -> b
$ SnocList (Fulfiller RawMPtr)
-> Fulfiller RawMPtr -> SnocList (Fulfiller RawMPtr)
forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList (Fulfiller RawMPtr)
subscribers Fulfiller RawMPtr
ptrFulfiller
            Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
ret
        ReadyPipeline Either Exception RawMPtr
r -> do
            -- TODO(cleanup): factor out the commonalities between this and the above case.
            (Client
p, Fulfiller Client
f) <- STM (Client, Fulfiller Client)
forall (m :: * -> *) c.
(MonadSTM m, IsClient c) =>
m (c, Fulfiller c)
newPromiseClient
            case Either Exception RawMPtr
r of
                Left Exception
e -> Fulfiller Client -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller Client
f Exception
e STM () -> STM Client -> STM Client
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
p
                Right RawMPtr
v ->
                    [Word16] -> RawMPtr -> STM Client
forall (m :: * -> *).
MonadThrow m =>
[Word16] -> RawMPtr -> m Client
ptrPathClient (SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
steps) RawMPtr
v
                    STM Client -> (SomeException -> STM Client) -> STM Client
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
`catchSTM` (\SomeException
e -> do
                        Fulfiller Client -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller Client
f (Bool -> SomeException -> Exception
wrapException Bool
False SomeException
e)
                        Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
p)

-- | Wait for the pipeline's target to resolve, and return the corresponding
-- pointer.
waitPipeline :: MonadSTM m => Pipeline -> m RawMPtr
waitPipeline :: Pipeline -> m RawMPtr
waitPipeline Pipeline{TVar PipelineState
state :: TVar PipelineState
$sel:state:Pipeline :: Pipeline -> TVar PipelineState
state, SnocList Word16
steps :: SnocList Word16
$sel:steps:Pipeline :: Pipeline -> SnocList Word16
steps} = STM RawMPtr -> m RawMPtr
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM RawMPtr -> m RawMPtr) -> STM RawMPtr -> m RawMPtr
forall a b. (a -> b) -> a -> b
$ do
    PipelineState
s <- TVar PipelineState -> STM PipelineState
forall a. TVar a -> STM a
readTVar TVar PipelineState
state
    case PipelineState
s of
        ReadyPipeline (Left Exception
e) ->
            Exception -> STM RawMPtr
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Exception
e
        ReadyPipeline (Right RawMPtr
v) ->
            WordCount -> LimitT STM RawMPtr -> STM RawMPtr
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT STM RawMPtr -> STM RawMPtr)
-> LimitT STM RawMPtr -> STM RawMPtr
forall a b. (a -> b) -> a -> b
$ [Word16] -> RawMPtr -> LimitT STM RawMPtr
forall (m :: * -> *).
ReadCtx m 'Const =>
[Word16] -> RawMPtr -> m RawMPtr
followPtrs (SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
steps) RawMPtr
v
        PipelineState
_ ->
            STM RawMPtr
forall a. STM a
retry

promisedAnswerClient :: Conn -> PromisedAnswer -> STM Client
promisedAnswerClient :: Conn -> PromisedAnswer -> STM Client
promisedAnswerClient Conn
conn answer :: PromisedAnswer
answer@PromisedAnswer{QAId
answerId :: QAId
$sel:answerId:PromisedAnswer :: PromisedAnswer -> QAId
answerId, SnocList Word16
transform :: SnocList Word16
$sel:transform:PromisedAnswer :: PromisedAnswer -> SnocList Word16
transform} = do
    let tmpDest :: TmpDest
tmpDest = RemoteDest -> TmpDest
RemoteDest AnswerDest :: Conn -> PromisedAnswer -> RemoteDest
AnswerDest { Conn
$sel:conn:AnswerDest :: Conn
conn :: Conn
conn, PromisedAnswer
$sel:answer:AnswerDest :: PromisedAnswer
answer :: PromisedAnswer
answer }
    TVar PromiseState
pState <- PromiseState -> STM (TVar PromiseState)
forall a. a -> STM (TVar a)
newTVar Pending :: TmpDest -> PromiseState
Pending { TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest :: TmpDest
tmpDest }
    ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap (Map Conn IEId -> ExportMap)
-> STM (Map Conn IEId) -> STM ExportMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map Conn IEId)
forall key value. STM (Map key value)
M.new
    let client :: Client
client = Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just PromiseClient :: TVar PromiseState -> ExportMap -> TmpDest -> Client'
PromiseClient
            { TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: TVar PromiseState
pState
            , ExportMap
exportMap :: ExportMap
$sel:exportMap:LocalClient :: ExportMap
exportMap
            , $sel:origTarget:LocalClient :: TmpDest
origTarget = TmpDest
tmpDest
            }
    TVar LiveState -> STM LiveState
forall a. TVar a -> STM a
readTVar (Conn -> TVar LiveState
liveState Conn
conn) STM LiveState -> (LiveState -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        LiveState
Dead ->
            TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest (TVar PromiseState -> PromiseState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) Exception
eDisconnected
        Live conn' :: Conn'
conn'@Conn'{Map QAId EntryQA
questions :: Map QAId EntryQA
$sel:questions:Conn' :: Conn' -> Map QAId EntryQA
questions} ->
            Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"questions" Conn'
conn' Map QAId EntryQA
questions QAId
answerId ((Return -> STM ()) -> STM ()) -> (Return -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$
                TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest (TVar PromiseState -> PromiseState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) Conn'
conn' (SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
transform)
    Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
client

-- | The current state of a 'PromiseClient'.
data PromiseState
    -- | The promise is fully resolved.
    = Ready
        { PromiseState -> Client
target :: Client
        -- ^ Capability to which the promise resolved.
        }
    -- | The promise has resolved, but is waiting on a Disembargo message
    -- before it is safe to send it messages.
    | Embargo
        { PromiseState -> TQueue CallInfo
callBuffer :: TQueue Server.CallInfo
        -- ^ A queue in which to buffer calls while waiting for the
        -- disembargo.
        }
    -- | The promise has not yet resolved.
    | Pending
        { PromiseState -> TmpDest
tmpDest :: TmpDest
        -- ^ A temporary destination to send calls, while we wait for the
        -- promise to resolve.
        }
    -- | The promise resolved to an exception.
    | Error R.Exception

-- | A temporary destination for calls on an unresolved promise.
data TmpDest
    -- | A destination that is local to this vat.
    = LocalDest LocalDest
    -- | A destination in another vat.
    | RemoteDest RemoteDest

newtype LocalDest
    -- | Queue the calls in a buffer.
    = LocalBuffer { LocalDest -> TQueue CallInfo
callBuffer :: TQueue Server.CallInfo }

data RemoteDest
    -- | Send call messages to a remote vat, targeting the results
    -- of an outstanding question.
    = AnswerDest
        { RemoteDest -> Conn
conn   :: Conn
        -- ^ The connection to the remote vat.
        , RemoteDest -> PromisedAnswer
answer :: PromisedAnswer
        -- ^ The answer to target.
        }
    -- | Send call messages to a remote vat, targeting an entry in our
    -- imports table.
    | ImportDest (Fin.Cell ImportRef)

-- | A reference to a capability in our import table/a remote vat's export
-- table.
data ImportRef = ImportRef
    { ImportRef -> Conn
conn     :: Conn
    -- ^ The connection to the remote vat.
    , ImportRef -> IEId
importId :: !IEId
    -- ^ The import id for this capability.
    , ImportRef -> ExportMap
proxies  :: ExportMap
    -- ^ Export ids to use when this client is passed to a vat other than
    -- the one identified by 'conn'. See Note [proxies]
    }

-- Ideally we could just derive these, but stm-containers doesn't have Eq
-- instances, so neither does ExportMap. not all of the fields are actually
-- necessary to check equality though. See also
-- https://github.com/nikita-volkov/stm-hamt/pull/1
instance Eq ImportRef where
    ImportRef { $sel:conn:ImportRef :: ImportRef -> Conn
conn=Conn
cx, $sel:importId:ImportRef :: ImportRef -> IEId
importId=IEId
ix } == :: ImportRef -> ImportRef -> Bool
== ImportRef { $sel:conn:ImportRef :: ImportRef -> Conn
conn=Conn
cy, $sel:importId:ImportRef :: ImportRef -> IEId
importId=IEId
iy } =
        Conn
cx Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
cy Bool -> Bool -> Bool
&& IEId
ix IEId -> IEId -> Bool
forall a. Eq a => a -> a -> Bool
== IEId
iy
instance Eq Client' where
    LocalClient { $sel:qCall:LocalClient :: Client' -> Rc (CallInfo -> STM ())
qCall = Rc (CallInfo -> STM ())
x } == :: Client' -> Client' -> Bool
== LocalClient { $sel:qCall:LocalClient :: Client' -> Rc (CallInfo -> STM ())
qCall = Rc (CallInfo -> STM ())
y } =
        Rc (CallInfo -> STM ())
x Rc (CallInfo -> STM ()) -> Rc (CallInfo -> STM ()) -> Bool
forall a. Eq a => a -> a -> Bool
== Rc (CallInfo -> STM ())
y
    PromiseClient { $sel:pState:LocalClient :: Client' -> TVar PromiseState
pState = TVar PromiseState
x } == PromiseClient { $sel:pState:LocalClient :: Client' -> TVar PromiseState
pState = TVar PromiseState
y } =
        TVar PromiseState
x TVar PromiseState -> TVar PromiseState -> Bool
forall a. Eq a => a -> a -> Bool
== TVar PromiseState
y
    ImportClient Cell ImportRef
x == ImportClient Cell ImportRef
y =
        Cell ImportRef
x Cell ImportRef -> Cell ImportRef -> Bool
forall a. Eq a => a -> a -> Bool
== Cell ImportRef
y
    Client'
_ == Client'
_ =
        Bool
False


-- | an 'ExportMap' tracks a mapping from connections to export IDs; it is
-- used to ensure that we re-use export IDs for capabilities when passing
-- them to remote vats. This used for locally hosted capabilities, but also
-- by proxied imports (see Note [proxies]).
newtype ExportMap = ExportMap (M.Map Conn IEId)

-- The below correspond to the similarly named types in
-- rpc.capnp, except:
--
-- * They use our newtype wrappers for ids
-- * They don't have unknown variants
-- * AnyPointers are left un-parsed
-- * PromisedAnswer's transform field is just a list of pointer offsets,
--   rather than a union with no other actually-useful variants.
-- * PromisedAnswer's transform field is a SnocList, for efficient appending.
data MsgTarget
    = ImportTgt !IEId
    | AnswerTgt PromisedAnswer
data PromisedAnswer = PromisedAnswer
    { PromisedAnswer -> QAId
answerId  :: !QAId
    , PromisedAnswer -> SnocList Word16
transform :: SnocList Word16
    }
data Call = Call
    { Call -> QAId
questionId  :: !QAId
    , Call -> MsgTarget
target      :: !MsgTarget
    , Call -> Word64
interfaceId :: !Word64
    , Call -> Word16
methodId    :: !Word16
    , Call -> Payload
params      :: !Payload
    }
data Return = Return
    { Return -> QAId
answerId         :: !QAId
    , Return -> Bool
releaseParamCaps :: !Bool
    , Return -> Return'
union'           :: Return'
    }
data Return'
    = Return'results Payload
    | Return'exception R.Exception
    | Return'canceled
    | Return'resultsSentElsewhere
    | Return'takeFromOtherQuestion QAId
    | Return'acceptFromThirdParty RawMPtr
data Payload = Payload
    { Payload -> RawMPtr
content  :: RawMPtr
    , Payload -> Vector CapDescriptor
capTable :: V.Vector R.CapDescriptor
    }

-- Note [proxies]
-- ==============
--
-- It is possible to have multiple connections open at once, and pass around
-- clients freely between them. Without level 3 support, this means that when
-- we pass a capability pointing into Vat A to another Vat B, we must proxy it.
--
-- To achieve this, capabilities pointing into a remote vat hold an 'ExportMap',
-- which tracks which export IDs we should be using to proxy the client on each
-- connection.

-- | Queue a call on a client.
call :: MonadSTM m => Server.CallInfo -> Client -> m Pipeline
call :: CallInfo -> Client -> m Pipeline
call Server.CallInfo { Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response } (Client Maybe Client'
Nothing) = STM Pipeline -> m Pipeline
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM Pipeline -> m Pipeline) -> STM Pipeline -> m Pipeline
forall a b. (a -> b) -> a -> b
$ do
    Fulfiller RawMPtr -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller RawMPtr
response Exception
eMethodUnimplemented
    TVar PipelineState
state <- PipelineState -> STM (TVar PipelineState)
forall a. a -> STM (TVar a)
newTVar (PipelineState -> STM (TVar PipelineState))
-> PipelineState -> STM (TVar PipelineState)
forall a b. (a -> b) -> a -> b
$ Either Exception RawMPtr -> PipelineState
ReadyPipeline (Exception -> Either Exception RawMPtr
forall a b. a -> Either a b
Left Exception
eMethodUnimplemented)
    Pipeline -> STM Pipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipeline :: TVar PipelineState -> SnocList Word16 -> Pipeline
Pipeline{TVar PipelineState
state :: TVar PipelineState
$sel:state:Pipeline :: TVar PipelineState
state, $sel:steps:Pipeline :: SnocList Word16
steps = SnocList Word16
forall a. Monoid a => a
mempty}
call info :: CallInfo
info@Server.CallInfo { Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response } (Client (Just Client'
client')) = STM Pipeline -> m Pipeline
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM Pipeline -> m Pipeline) -> STM Pipeline -> m Pipeline
forall a b. (a -> b) -> a -> b
$ do
    (Pipeline
localPipeline, Fulfiller RawMPtr
response') <- Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr)
makeLocalPipeline Fulfiller RawMPtr
response
    let info' :: CallInfo
info' = CallInfo
info { response :: Fulfiller RawMPtr
Server.response = Fulfiller RawMPtr
response' }
    case Client'
client' of
        LocalClient { Rc (CallInfo -> STM ())
qCall :: Rc (CallInfo -> STM ())
$sel:qCall:LocalClient :: Client' -> Rc (CallInfo -> STM ())
qCall } -> do
            Rc (CallInfo -> STM ()) -> STM (Maybe (CallInfo -> STM ()))
forall a. Rc a -> STM (Maybe a)
Rc.get Rc (CallInfo -> STM ())
qCall STM (Maybe (CallInfo -> STM ()))
-> (Maybe (CallInfo -> STM ()) -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just CallInfo -> STM ()
q -> do
                    CallInfo -> STM ()
q CallInfo
info'
                Maybe (CallInfo -> STM ())
Nothing ->
                    Fulfiller RawMPtr -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller RawMPtr
response' Exception
eDisconnected
            Pipeline -> STM Pipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipeline
localPipeline

        PromiseClient { TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: Client' -> TVar PromiseState
pState } -> TVar PromiseState -> STM PromiseState
forall a. TVar a -> STM a
readTVar TVar PromiseState
pState STM PromiseState -> (PromiseState -> STM Pipeline) -> STM Pipeline
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Ready { Client
target :: Client
$sel:target:Ready :: PromiseState -> Client
target }  ->
                CallInfo -> Client -> STM Pipeline
forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m Pipeline
call CallInfo
info Client
target

            Embargo { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:Ready :: PromiseState -> TQueue CallInfo
callBuffer } -> do
                TQueue CallInfo -> CallInfo -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue CallInfo
callBuffer CallInfo
info'
                Pipeline -> STM Pipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipeline
localPipeline

            Pending { TmpDest
tmpDest :: TmpDest
$sel:tmpDest:Ready :: PromiseState -> TmpDest
tmpDest } -> case TmpDest
tmpDest of
                LocalDest LocalBuffer { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: LocalDest -> TQueue CallInfo
callBuffer } -> do
                    TQueue CallInfo -> CallInfo -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue CallInfo
callBuffer CallInfo
info'
                    Pipeline -> STM Pipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipeline
localPipeline

                RemoteDest AnswerDest { Conn
conn :: Conn
$sel:conn:AnswerDest :: RemoteDest -> Conn
conn, PromisedAnswer
answer :: PromisedAnswer
$sel:answer:AnswerDest :: RemoteDest -> PromisedAnswer
answer } ->
                    Conn -> CallInfo -> MsgTarget -> STM Pipeline
callRemote Conn
conn CallInfo
info (MsgTarget -> STM Pipeline) -> MsgTarget -> STM Pipeline
forall a b. (a -> b) -> a -> b
$ PromisedAnswer -> MsgTarget
AnswerTgt PromisedAnswer
answer

                RemoteDest (ImportDest Cell ImportRef
cell) -> do
                    ImportRef { Conn
conn :: Conn
$sel:conn:ImportRef :: ImportRef -> Conn
conn, IEId
importId :: IEId
$sel:importId:ImportRef :: ImportRef -> IEId
importId } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
                    Conn -> CallInfo -> MsgTarget -> STM Pipeline
callRemote Conn
conn CallInfo
info (MsgTarget -> STM Pipeline) -> MsgTarget -> STM Pipeline
forall a b. (a -> b) -> a -> b
$ IEId -> MsgTarget
ImportTgt IEId
importId

            Error Exception
exn -> do
                Fulfiller RawMPtr -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller RawMPtr
response' Exception
exn
                Pipeline -> STM Pipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipeline
localPipeline

        ImportClient Cell ImportRef
cell -> do
            ImportRef { Conn
conn :: Conn
$sel:conn:ImportRef :: ImportRef -> Conn
conn, IEId
importId :: IEId
$sel:importId:ImportRef :: ImportRef -> IEId
importId } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
            Conn -> CallInfo -> MsgTarget -> STM Pipeline
callRemote Conn
conn CallInfo
info (IEId -> MsgTarget
ImportTgt IEId
importId)

makeLocalPipeline :: Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr)
makeLocalPipeline :: Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr)
makeLocalPipeline Fulfiller RawMPtr
f = do
    TVar PipelineState
state <- PipelineState -> STM (TVar PipelineState)
forall a. a -> STM (TVar a)
newTVar (PipelineState -> STM (TVar PipelineState))
-> PipelineState -> STM (TVar PipelineState)
forall a b. (a -> b) -> a -> b
$ SnocList (Fulfiller RawMPtr) -> PipelineState
PendingLocalPipeline SnocList (Fulfiller RawMPtr)
forall a. Monoid a => a
mempty
    Fulfiller RawMPtr
f' <- (Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr)
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr))
-> (Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr)
forall a b. (a -> b) -> a -> b
$ \Either Exception RawMPtr
r -> do
        PipelineState
s <- TVar PipelineState -> STM PipelineState
forall a. TVar a -> STM a
readTVar TVar PipelineState
state
        case PipelineState
s of
            PendingLocalPipeline SnocList (Fulfiller RawMPtr)
fs -> do
                TVar PipelineState -> PipelineState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
state (Either Exception RawMPtr -> PipelineState
ReadyPipeline Either Exception RawMPtr
r)
                Fulfiller RawMPtr -> Either Exception RawMPtr -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
breakOrFulfill Fulfiller RawMPtr
f Either Exception RawMPtr
r
                (Fulfiller RawMPtr -> STM ())
-> SnocList (Fulfiller RawMPtr) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Fulfiller RawMPtr -> Either Exception RawMPtr -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
`breakOrFulfill` Either Exception RawMPtr
r) SnocList (Fulfiller RawMPtr)
fs
            PipelineState
_ ->
                -- TODO(cleanup): refactor so we don't need this case.
                String -> STM ()
forall a. HasCallStack => String -> a
error String
"impossible"
    (Pipeline, Fulfiller RawMPtr) -> STM (Pipeline, Fulfiller RawMPtr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pipeline :: TVar PipelineState -> SnocList Word16 -> Pipeline
Pipeline{TVar PipelineState
state :: TVar PipelineState
$sel:state:Pipeline :: TVar PipelineState
state, $sel:steps:Pipeline :: SnocList Word16
steps = SnocList Word16
forall a. Monoid a => a
mempty}, Fulfiller RawMPtr
f')

-- | Send a call to a remote capability.
callRemote :: Conn -> Server.CallInfo -> MsgTarget -> STM Pipeline
callRemote :: Conn -> CallInfo -> MsgTarget -> STM Pipeline
callRemote
        Conn
conn
        Server.CallInfo{ Word64
interfaceId :: CallInfo -> Word64
interfaceId :: Word64
interfaceId, Word16
methodId :: CallInfo -> Word16
methodId :: Word16
methodId, RawMPtr
arguments :: CallInfo -> RawMPtr
arguments :: RawMPtr
arguments, Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response }
        MsgTarget
target = do
    conn' :: Conn'
conn'@Conn'{Map QAId EntryQA
questions :: Map QAId EntryQA
$sel:questions:Conn' :: Conn' -> Map QAId EntryQA
questions} <- Conn -> STM Conn'
getLive Conn
conn
    QAId
qid <- Conn' -> STM QAId
newQuestion Conn'
conn'
    payload :: Payload
payload@Payload{Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable} <- Conn -> RawMPtr -> STM Payload
makeOutgoingPayload Conn
conn RawMPtr
arguments
    Conn' -> Call -> STM ()
sendCall Conn'
conn' Call :: QAId -> MsgTarget -> Word64 -> Word16 -> Payload -> Call
Call
        { $sel:questionId:Call :: QAId
questionId = QAId
qid
        , $sel:target:Call :: MsgTarget
target = MsgTarget
target
        , $sel:params:Call :: Payload
params = Payload
payload
        , Word64
interfaceId :: Word64
$sel:interfaceId:Call :: Word64
interfaceId
        , Word16
methodId :: Word16
$sel:methodId:Call :: Word16
methodId
        }
    -- save these in case the callee sends back releaseParamCaps = True in the return
    -- message:
    let paramCaps :: [IEId]
paramCaps = [Maybe IEId] -> [IEId]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe IEId] -> [IEId]) -> [Maybe IEId] -> [IEId]
forall a b. (a -> b) -> a -> b
$ ((CapDescriptor -> Maybe IEId) -> [CapDescriptor] -> [Maybe IEId])
-> [CapDescriptor] -> (CapDescriptor -> Maybe IEId) -> [Maybe IEId]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CapDescriptor -> Maybe IEId) -> [CapDescriptor] -> [Maybe IEId]
forall a b. (a -> b) -> [a] -> [b]
map (Vector CapDescriptor -> [CapDescriptor]
forall a. Vector a -> [a]
V.toList Vector CapDescriptor
capTable) ((CapDescriptor -> Maybe IEId) -> [Maybe IEId])
-> (CapDescriptor -> Maybe IEId) -> [Maybe IEId]
forall a b. (a -> b) -> a -> b
$ \R.CapDescriptor{CapDescriptor'
$sel:union':CapDescriptor :: CapDescriptor -> CapDescriptor'
union' :: CapDescriptor'
union'} -> case CapDescriptor'
union' of
            R.CapDescriptor'senderHosted  Word32
eid -> IEId -> Maybe IEId
forall a. a -> Maybe a
Just (Word32 -> IEId
IEId Word32
eid)
            R.CapDescriptor'senderPromise Word32
eid -> IEId -> Maybe IEId
forall a. a -> Maybe a
Just (Word32 -> IEId
IEId Word32
eid)
            CapDescriptor'
_                                 -> Maybe IEId
forall a. Maybe a
Nothing

    Map (SnocList Word16) Client
clientMap <- STM (Map (SnocList Word16) Client)
forall key value. STM (Map key value)
M.new
    TVar PipelineState
rp <- PipelineState -> STM (TVar PipelineState)
forall a. a -> STM (TVar a)
newTVar PendingRemotePipeline :: QAId -> Map (SnocList Word16) Client -> Conn -> PipelineState
PendingRemotePipeline
        { $sel:answerId:PendingRemotePipeline :: QAId
answerId = QAId
qid
        , Map (SnocList Word16) Client
clientMap :: Map (SnocList Word16) Client
$sel:clientMap:PendingRemotePipeline :: Map (SnocList Word16) Client
clientMap
        , Conn
conn :: Conn
$sel:conn:PendingRemotePipeline :: Conn
conn
        }

    Fulfiller RawMPtr
response' <- (Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr)
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr))
-> (Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr)
forall a b. (a -> b) -> a -> b
$ \Either Exception RawMPtr
r -> do
        Fulfiller RawMPtr -> Either Exception RawMPtr -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
breakOrFulfill Fulfiller RawMPtr
response Either Exception RawMPtr
r
        case Either Exception RawMPtr
r of
            Left Exception
e -> TVar PipelineState -> PipelineState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
rp (PipelineState -> STM ()) -> PipelineState -> STM ()
forall a b. (a -> b) -> a -> b
$ Either Exception RawMPtr -> PipelineState
ReadyPipeline (Exception -> Either Exception RawMPtr
forall a b. a -> Either a b
Left Exception
e)
            Right RawMPtr
v ->
                TVar PipelineState -> PipelineState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
rp (PipelineState -> STM ()) -> PipelineState -> STM ()
forall a b. (a -> b) -> a -> b
$ Either Exception RawMPtr -> PipelineState
ReadyPipeline (RawMPtr -> Either Exception RawMPtr
forall a b. b -> Either a b
Right RawMPtr
v)

    EntryQA -> QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
        NewQA :: SnocList (Finish -> STM ())
-> SnocList (Return -> STM ()) -> EntryQA
NewQA
            { $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn = (Return -> STM ()) -> SnocList (Return -> STM ())
forall a. a -> SnocList a
SnocList.singleton ((Return -> STM ()) -> SnocList (Return -> STM ()))
-> (Return -> STM ()) -> SnocList (Return -> STM ())
forall a b. (a -> b) -> a -> b
$ [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM ()
cbCallReturn [IEId]
paramCaps Conn
conn Fulfiller RawMPtr
response'
            , $sel:onFinish:NewQA :: SnocList (Finish -> STM ())
onFinish = SnocList (Finish -> STM ())
forall a. SnocList a
SnocList.empty
            }
        QAId
qid
        Map QAId EntryQA
questions
    Pipeline -> STM Pipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipeline :: TVar PipelineState -> SnocList Word16 -> Pipeline
Pipeline { $sel:state:Pipeline :: TVar PipelineState
state = TVar PipelineState
rp, $sel:steps:Pipeline :: SnocList Word16
steps = SnocList Word16
forall a. Monoid a => a
mempty }

-- | Callback to run when a return comes in that corresponds to a call
-- we sent. Registered in callRemote. The first argument is a list of
-- export IDs to release if the return message has releaseParamCaps = true.
cbCallReturn :: [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM ()
cbCallReturn :: [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM ()
cbCallReturn
        [IEId]
paramCaps
        Conn
conn
        Fulfiller RawMPtr
response
        Return{ QAId
answerId :: QAId
$sel:answerId:Return :: Return -> QAId
answerId, Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union', Bool
releaseParamCaps :: Bool
$sel:releaseParamCaps:Return :: Return -> Bool
releaseParamCaps } = do
    conn' :: Conn'
conn'@Conn'{Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} <- Conn -> STM Conn'
getLive Conn
conn
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
releaseParamCaps (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
        (IEId -> STM ()) -> [IEId] -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Word32
1) [IEId]
paramCaps
    case Return'
union' of
        Return'exception Exception
exn ->
            Fulfiller RawMPtr -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller RawMPtr
response Exception
exn
        Return'results Payload{ RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content } ->
            Fulfiller RawMPtr -> RawMPtr -> STM ()
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller RawMPtr
response RawMPtr
content
        Return'
Return'canceled ->
            Fulfiller RawMPtr -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller RawMPtr
response (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed Text
"Canceled"

        Return'
Return'resultsSentElsewhere ->
            -- This should never happen, since we always set
            -- sendResultsTo = caller
            Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"Received Return.resultsSentElswhere for a call "
                , Text
"with sendResultsTo = caller."
                ]

        Return'takeFromOtherQuestion QAId
qid ->
            -- TODO(cleanup): we should be a little stricter; the protocol
            -- requires that (1) each answer is only used this way once, and
            -- (2) The question was sent with sendResultsTo set to 'yourself',
            -- but we don't enforce either of these requirements.
            Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"answer" Conn'
conn' Map QAId EntryQA
answers QAId
qid ((Return -> STM ()) -> STM ()) -> (Return -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$
                [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM ()
cbCallReturn [] Conn
conn Fulfiller RawMPtr
response

        Return'acceptFromThirdParty RawMPtr
_ ->
            -- Note [Level 3]
            Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eUnimplemented
                Text
"This vat does not support level 3."
    -- Defer this until after any other callbacks run, in case disembargos
    -- need to be sent due to promise resolutions that we triggered:
    Conn' -> STM () -> STM ()
queueSTM Conn'
conn' (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ Conn' -> Finish -> STM ()
finishQuestion Conn'
conn' Finish
forall a. Default a => a
def
        { $sel:questionId:Finish :: Word32
R.questionId = QAId -> Word32
qaWord QAId
answerId
        , $sel:releaseResultCaps:Finish :: Bool
R.releaseResultCaps = Bool
False
        }


marshalMsgTarget :: MsgTarget -> R.MessageTarget
marshalMsgTarget :: MsgTarget -> MessageTarget
marshalMsgTarget = \case
    ImportTgt IEId
importId ->
        Word32 -> MessageTarget
R.MessageTarget'importedCap (IEId -> Word32
ieWord IEId
importId)
    AnswerTgt PromisedAnswer
tgt ->
        PromisedAnswer -> MessageTarget
R.MessageTarget'promisedAnswer (PromisedAnswer -> MessageTarget)
-> PromisedAnswer -> MessageTarget
forall a b. (a -> b) -> a -> b
$ PromisedAnswer -> PromisedAnswer
marshalPromisedAnswer PromisedAnswer
tgt

marshalPromisedAnswer :: PromisedAnswer -> R.PromisedAnswer
marshalPromisedAnswer :: PromisedAnswer -> PromisedAnswer
marshalPromisedAnswer PromisedAnswer{ QAId
answerId :: QAId
$sel:answerId:PromisedAnswer :: PromisedAnswer -> QAId
answerId, SnocList Word16
transform :: SnocList Word16
$sel:transform:PromisedAnswer :: PromisedAnswer -> SnocList Word16
transform } =
    PromisedAnswer :: Word32 -> Vector PromisedAnswer'Op -> PromisedAnswer
R.PromisedAnswer
        { $sel:questionId:PromisedAnswer :: Word32
R.questionId = QAId -> Word32
qaWord QAId
answerId
        , $sel:transform:PromisedAnswer :: Vector PromisedAnswer'Op
R.transform =
            [PromisedAnswer'Op] -> Vector PromisedAnswer'Op
forall a. [a] -> Vector a
V.fromList ([PromisedAnswer'Op] -> Vector PromisedAnswer'Op)
-> [PromisedAnswer'Op] -> Vector PromisedAnswer'Op
forall a b. (a -> b) -> a -> b
$
                (Word16 -> PromisedAnswer'Op) -> [Word16] -> [PromisedAnswer'Op]
forall a b. (a -> b) -> [a] -> [b]
map Word16 -> PromisedAnswer'Op
R.PromisedAnswer'Op'getPointerField ([Word16] -> [PromisedAnswer'Op])
-> [Word16] -> [PromisedAnswer'Op]
forall a b. (a -> b) -> a -> b
$
                    SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
transform
        }

unmarshalPromisedAnswer :: MonadThrow m => R.PromisedAnswer -> m PromisedAnswer
unmarshalPromisedAnswer :: PromisedAnswer -> m PromisedAnswer
unmarshalPromisedAnswer R.PromisedAnswer { Word32
questionId :: Word32
$sel:questionId:PromisedAnswer :: PromisedAnswer -> Word32
questionId, Vector PromisedAnswer'Op
transform :: Vector PromisedAnswer'Op
$sel:transform:PromisedAnswer :: PromisedAnswer -> Vector PromisedAnswer'Op
transform } = do
    [Word16]
idxes <- [PromisedAnswer'Op] -> m [Word16]
forall (m :: * -> *).
MonadThrow m =>
[PromisedAnswer'Op] -> m [Word16]
unmarshalOps (Vector PromisedAnswer'Op -> [PromisedAnswer'Op]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector PromisedAnswer'Op
transform)
    PromisedAnswer -> m PromisedAnswer
forall (f :: * -> *) a. Applicative f => a -> f a
pure PromisedAnswer :: QAId -> SnocList Word16 -> PromisedAnswer
PromisedAnswer
        { $sel:answerId:PromisedAnswer :: QAId
answerId = Word32 -> QAId
QAId Word32
questionId
        , $sel:transform:PromisedAnswer :: SnocList Word16
transform = [Word16] -> SnocList Word16
forall a. [a] -> SnocList a
SnocList.fromList [Word16]
idxes
        }

unmarshalOps :: MonadThrow m => [R.PromisedAnswer'Op] -> m [Word16]
unmarshalOps :: [PromisedAnswer'Op] -> m [Word16]
unmarshalOps [] = [Word16] -> m [Word16]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
unmarshalOps (PromisedAnswer'Op
R.PromisedAnswer'Op'noop:[PromisedAnswer'Op]
ops) =
    [PromisedAnswer'Op] -> m [Word16]
forall (m :: * -> *).
MonadThrow m =>
[PromisedAnswer'Op] -> m [Word16]
unmarshalOps [PromisedAnswer'Op]
ops
unmarshalOps (R.PromisedAnswer'Op'getPointerField Word16
i:[PromisedAnswer'Op]
ops) =
    (Word16
iWord16 -> [Word16] -> [Word16]
forall a. a -> [a] -> [a]
:) ([Word16] -> [Word16]) -> m [Word16] -> m [Word16]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PromisedAnswer'Op] -> m [Word16]
forall (m :: * -> *).
MonadThrow m =>
[PromisedAnswer'Op] -> m [Word16]
unmarshalOps [PromisedAnswer'Op]
ops
unmarshalOps (R.PromisedAnswer'Op'unknown' Word16
tag:[PromisedAnswer'Op]
_) =
    Exception -> m [Word16]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Exception -> m [Word16]) -> Exception -> m [Word16]
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ Text
"Unknown PromisedAnswer.Op: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word16 -> String
forall a. Show a => a -> String
show Word16
tag)


-- | A null client. This is the only client value that can be represented
-- statically. Throws exceptions in response to all method calls.
nullClient :: Client
nullClient :: Client
nullClient = Maybe Client' -> Client
Client Maybe Client'
forall a. Maybe a
Nothing

-- | Create a new client based on a promise. The fulfiller can be used to
-- supply the final client.
newPromiseClient :: (MonadSTM m, IsClient c) => m (c, Fulfiller c)
newPromiseClient :: m (c, Fulfiller c)
newPromiseClient = STM (c, Fulfiller c) -> m (c, Fulfiller c)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (c, Fulfiller c) -> m (c, Fulfiller c))
-> STM (c, Fulfiller c) -> m (c, Fulfiller c)
forall a b. (a -> b) -> a -> b
$ do
    TQueue CallInfo
callBuffer <- STM (TQueue CallInfo)
forall a. STM (TQueue a)
newTQueue
    let tmpDest :: TmpDest
tmpDest = LocalDest -> TmpDest
LocalDest LocalBuffer :: TQueue CallInfo -> LocalDest
LocalBuffer { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: TQueue CallInfo
callBuffer }
    TVar PromiseState
pState <- PromiseState -> STM (TVar PromiseState)
forall a. a -> STM (TVar a)
newTVar Pending :: TmpDest -> PromiseState
Pending { TmpDest
tmpDest :: TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest }
    ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap (Map Conn IEId -> ExportMap)
-> STM (Map Conn IEId) -> STM ExportMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map Conn IEId)
forall key value. STM (Map key value)
M.new
    Fulfiller c
f <- (Either Exception c -> STM ()) -> STM (Fulfiller c)
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception c -> STM ()) -> STM (Fulfiller c))
-> (Either Exception c -> STM ()) -> STM (Fulfiller c)
forall a b. (a -> b) -> a -> b
$ \case
        Left Exception
e  -> TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest (TVar PromiseState -> PromiseState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) Exception
e
        Right c
v -> TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest (TVar PromiseState -> PromiseState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) (c -> Client
forall a. IsClient a => a -> Client
toClient c
v)
    let p :: Client
p = Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just (Client' -> Maybe Client') -> Client' -> Maybe Client'
forall a b. (a -> b) -> a -> b
$ PromiseClient :: TVar PromiseState -> ExportMap -> TmpDest -> Client'
PromiseClient
            { TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: TVar PromiseState
pState
            , ExportMap
exportMap :: ExportMap
$sel:exportMap:LocalClient :: ExportMap
exportMap
            , $sel:origTarget:LocalClient :: TmpDest
origTarget = TmpDest
tmpDest
            }
    (c, Fulfiller c) -> STM (c, Fulfiller c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> c
forall a. IsClient a => Client -> a
fromClient Client
p, Fulfiller c
f)


-- | Attempt to unwrap a client, to get at an underlying value from the
-- server. Returns 'Nothing' on failure.
--
-- This shells out to the underlying server's implementation of
-- 'Server.unwrap'. It will fail with 'Nothing' if any of these are true:
--
-- * The client is a promise.
-- * The client points to an object in a remote vat.
-- * The underlying Server's 'unwrap' method returns 'Nothing' for type 'a'.
unwrapServer :: (IsClient c, Typeable a) => c -> Maybe a
unwrapServer :: c -> Maybe a
unwrapServer c
c = case c -> Client
forall a. IsClient a => a -> Client
toClient c
c of
    Client (Just LocalClient { forall a. Typeable a => Maybe a
unwrapper :: forall a. Typeable a => Maybe a
$sel:unwrapper:LocalClient :: Client' -> forall a. Typeable a => Maybe a
unwrapper }) -> Maybe a
forall a. Typeable a => Maybe a
unwrapper
    Client
_                                       -> Maybe a
forall a. Maybe a
Nothing


-- | Wait for the client to be fully resolved, and then return a client
-- pointing directly to the destination.
--
-- If the argument is null, a local client, or a (permanent) remote client,
-- this returns the argument immediately. If the argument is a promise client,
-- then this waits for the promise to resolve and returns the result of
-- the resolution. If the promise resolves to *another* promise, then this waits
-- for that promise to also resolve.
--
-- If the promise is rejected, then this throws the corresponding exception.
waitClient :: (IsClient c, MonadSTM m) => c -> m c
waitClient :: c -> m c
waitClient c
client = STM c -> m c
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM c -> m c) -> STM c -> m c
forall a b. (a -> b) -> a -> b
$ case c -> Client
forall a. IsClient a => a -> Client
toClient c
client of
    Client Maybe Client'
Nothing -> c -> STM c
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
client
    Client (Just LocalClient{}) -> c -> STM c
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
client
    Client (Just ImportClient{}) -> c -> STM c
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
client
    Client (Just PromiseClient{TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: Client' -> TVar PromiseState
pState}) -> do
        PromiseState
state <- TVar PromiseState -> STM PromiseState
forall a. TVar a -> STM a
readTVar TVar PromiseState
pState
        case PromiseState
state of
            Ready{Client
target :: Client
$sel:target:Ready :: PromiseState -> Client
target} -> Client -> c
forall a. IsClient a => Client -> a
fromClient (Client -> c) -> STM Client -> STM c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client -> STM Client
forall c (m :: * -> *). (IsClient c, MonadSTM m) => c -> m c
waitClient Client
target
            Error Exception
e       -> Exception -> STM c
forall e a. Exception e => e -> STM a
throwSTM Exception
e
            Pending{}     -> STM c
forall a. STM a
retry
            Embargo{}     -> STM c
forall a. STM a
retry


-- | Spawn a local server with its lifetime bound to the supervisor,
-- and return a client for it. When the client is garbage collected,
-- the server will be stopped (if it is still running).
export :: MonadSTM m => Supervisor -> Server.ServerOps IO -> m Client
export :: Supervisor -> ServerOps IO -> m Client
export Supervisor
sup ServerOps IO
ops = STM Client -> m Client
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM Client -> m Client) -> STM Client -> m Client
forall a b. (a -> b) -> a -> b
$ do
    Q CallInfo
q <- STM (Q CallInfo)
forall a. STM (Q a)
TCloseQ.new
    Rc (CallInfo -> STM ())
qCall <- (CallInfo -> STM ()) -> STM () -> STM (Rc (CallInfo -> STM ()))
forall a. a -> STM () -> STM (Rc a)
Rc.new (Q CallInfo -> CallInfo -> STM ()
forall a. Q a -> a -> STM ()
TCloseQ.write Q CallInfo
q) (Q CallInfo -> STM ()
forall a. Q a -> STM ()
TCloseQ.close Q CallInfo
q)
    ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap (Map Conn IEId -> ExportMap)
-> STM (Map Conn IEId) -> STM ExportMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map Conn IEId)
forall key value. STM (Map key value)
M.new
    Cell ()
finalizerKey <- () -> STM (Cell ())
forall (m :: * -> *) a. MonadSTM m => a -> m (Cell a)
Fin.newCell ()
    let client' :: Client'
client' = LocalClient :: ExportMap
-> Rc (CallInfo -> STM ())
-> Cell ()
-> (forall a. Typeable a => Maybe a)
-> Client'
LocalClient
            { Rc (CallInfo -> STM ())
qCall :: Rc (CallInfo -> STM ())
$sel:qCall:LocalClient :: Rc (CallInfo -> STM ())
qCall
            , ExportMap
exportMap :: ExportMap
$sel:exportMap:LocalClient :: ExportMap
exportMap
            , Cell ()
finalizerKey :: Cell ()
$sel:finalizerKey:LocalClient :: Cell ()
finalizerKey
            , $sel:unwrapper:LocalClient :: forall a. Typeable a => Maybe a
unwrapper = ServerOps IO -> forall a. Typeable a => Maybe a
forall (m :: * -> *).
ServerOps m -> forall a. Typeable a => Maybe a
Server.handleCast ServerOps IO
ops
            }
    Supervisor -> IO () -> STM ()
superviseSTM Supervisor
sup ((do
        Cell () -> IO () -> IO ()
forall a. Cell a -> IO () -> IO ()
Fin.addFinalizer Cell ()
finalizerKey (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Rc (CallInfo -> STM ()) -> STM ()
forall a. Rc a -> STM ()
Rc.release Rc (CallInfo -> STM ())
qCall
        Q CallInfo -> ServerOps IO -> IO ()
Server.runServer Q CallInfo
q ServerOps IO
ops)
      IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` ServerOps IO -> IO ()
forall (m :: * -> *). ServerOps m -> m ()
Server.handleStop ServerOps IO
ops)
    Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> STM Client) -> Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Client' -> Maybe Client'
forall a. a -> Maybe a
Just Client'
client')

clientMethodHandler :: Word64 -> Word16 -> Client -> Server.MethodHandler IO p r
clientMethodHandler :: Word64 -> Word16 -> Client -> MethodHandler IO p r
clientMethodHandler Word64
interfaceId Word16
methodId Client
client =
    MethodHandler IO RawMPtr RawMPtr -> MethodHandler IO p r
forall (m :: * -> *) p r.
MethodHandler m RawMPtr RawMPtr -> MethodHandler m p r
Server.fromUntypedHandler (MethodHandler IO RawMPtr RawMPtr -> MethodHandler IO p r)
-> MethodHandler IO RawMPtr RawMPtr -> MethodHandler IO p r
forall a b. (a -> b) -> a -> b
$ (RawMPtr -> Fulfiller RawMPtr -> IO ())
-> MethodHandler IO RawMPtr RawMPtr
forall (m :: * -> *).
(RawMPtr -> Fulfiller RawMPtr -> m ())
-> MethodHandler m RawMPtr RawMPtr
Server.untypedHandler ((RawMPtr -> Fulfiller RawMPtr -> IO ())
 -> MethodHandler IO RawMPtr RawMPtr)
-> (RawMPtr -> Fulfiller RawMPtr -> IO ())
-> MethodHandler IO RawMPtr RawMPtr
forall a b. (a -> b) -> a -> b
$
        \RawMPtr
arguments Fulfiller RawMPtr
response -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Pipeline -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Pipeline -> STM ()) -> STM Pipeline -> STM ()
forall a b. (a -> b) -> a -> b
$ CallInfo -> Client -> STM Pipeline
forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m Pipeline
call CallInfo :: Word64 -> Word16 -> RawMPtr -> Fulfiller RawMPtr -> CallInfo
Server.CallInfo{RawMPtr
Word16
Word64
Fulfiller RawMPtr
response :: Fulfiller RawMPtr
arguments :: RawMPtr
methodId :: Word16
interfaceId :: Word64
arguments :: RawMPtr
methodId :: Word16
interfaceId :: Word64
response :: Fulfiller RawMPtr
..} Client
client

-- | See Note [callbacks]
callbacksLoop :: Conn' -> IO ()
callbacksLoop :: Conn' -> IO ()
callbacksLoop Conn'{TQueue (IO ())
pendingCallbacks :: TQueue (IO ())
$sel:pendingCallbacks:Conn' :: Conn' -> TQueue (IO ())
pendingCallbacks} = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [IO ()]
cbs <- STM [IO ()] -> IO [IO ()]
forall a. STM a -> IO a
atomically (STM [IO ()] -> IO [IO ()]) -> STM [IO ()] -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ TQueue (IO ()) -> STM [IO ()]
forall a. TQueue a -> STM [a]
flushTQueue TQueue (IO ())
pendingCallbacks STM [IO ()] -> ([IO ()] -> STM [IO ()]) -> STM [IO ()]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- We need to make sure to block if there weren't any jobs, since
        -- otherwise we'll busy loop, pegging the CPU.
        []  -> STM [IO ()]
forall a. STM a
retry
        [IO ()]
cbs -> [IO ()] -> STM [IO ()]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [IO ()]
cbs
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
cbs

-- Run the one iteration of the callbacks loop, without blocking.
flushCallbacks :: Conn' -> IO ()
flushCallbacks :: Conn' -> IO ()
flushCallbacks Conn'{TQueue (IO ())
pendingCallbacks :: TQueue (IO ())
$sel:pendingCallbacks:Conn' :: Conn' -> TQueue (IO ())
pendingCallbacks} =
    STM [IO ()] -> IO [IO ()]
forall a. STM a -> IO a
atomically (TQueue (IO ()) -> STM [IO ()]
forall a. TQueue a -> STM [a]
flushTQueue TQueue (IO ())
pendingCallbacks) IO [IO ()] -> ([IO ()] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_

-- | 'sendLoop' shunts messages from the send queue into the transport.
sendLoop :: Transport -> Conn' -> IO ()
sendLoop :: Transport -> Conn' -> IO ()
sendLoop Transport
transport Conn'{TBQueue (Message 'Const)
sendQ :: TBQueue (Message 'Const)
$sel:sendQ:Conn' :: Conn' -> TBQueue (Message 'Const)
sendQ} =
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (Message 'Const) -> IO (Message 'Const)
forall a. STM a -> IO a
atomically (TBQueue (Message 'Const) -> STM (Message 'Const)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (Message 'Const)
sendQ) IO (Message 'Const) -> (Message 'Const -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Transport -> Message 'Const -> IO ()
sendMsg Transport
transport

-- | 'recvLoop' shunts messages from the transport into the receive queue.
recvLoop :: Transport -> Conn' -> IO ()
recvLoop :: Transport -> Conn' -> IO ()
recvLoop Transport
transport Conn'{TBQueue (Message 'Const)
recvQ :: TBQueue (Message 'Const)
$sel:recvQ:Conn' :: Conn' -> TBQueue (Message 'Const)
recvQ} =
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Transport -> IO (Message 'Const)
recvMsg Transport
transport IO (Message 'Const) -> (Message 'Const -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (Message 'Const -> STM ()) -> Message 'Const -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue (Message 'Const) -> Message 'Const -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Message 'Const)
recvQ

-- | The coordinator processes incoming messages.
coordinator :: Conn -> IO ()
-- The logic here mostly routes messages to other parts of the code that know
-- more about the objects in question; See Note [Organization] for more info.
coordinator :: Conn -> IO ()
coordinator conn :: Conn
conn@Conn{Bool
debugMode :: Bool
$sel:debugMode:Conn :: Conn -> Bool
debugMode} = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    conn' :: Conn'
conn'@Conn'{TBQueue (Message 'Const)
recvQ :: TBQueue (Message 'Const)
$sel:recvQ:Conn' :: Conn' -> TBQueue (Message 'Const)
recvQ} <- Conn -> STM Conn'
getLive Conn
conn
    (STM () -> (SomeException -> STM ()) -> STM ())
-> (SomeException -> STM ()) -> STM () -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip STM () -> (SomeException -> STM ()) -> STM ()
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
catchSTM (RpcError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (RpcError -> STM ())
-> (SomeException -> RpcError) -> SomeException -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SomeException -> RpcError
makeAbortExn Bool
debugMode) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
        Message 'Const
capnpMsg <- TBQueue (Message 'Const) -> STM (Message 'Const)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (Message 'Const)
recvQ
        WordCount -> LimitT STM () -> STM ()
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT STM () -> STM ()) -> LimitT STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
            Message 'Const
root <- Message 'Const -> LimitT STM (Struct 'Const)
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Message mut -> m (Struct mut)
UntypedRaw.rootPtr Message 'Const
capnpMsg LimitT STM (Struct 'Const)
-> (Struct 'Const -> LimitT STM (Message 'Const))
-> LimitT STM (Message 'Const)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Struct 'Const -> LimitT STM (Message 'Const)
forall (mut :: Mutability) a (m :: * -> *).
(FromStruct mut a, ReadCtx m mut) =>
Struct mut -> m a
fromStruct
            Message' 'Const
msg' <- Message 'Const -> LimitT STM (Message' 'Const)
forall (m :: * -> *) (msg :: Mutability).
(ReadCtx m msg, FromStruct msg (Message' msg)) =>
Message msg -> m (Message' msg)
RawRpc.get_Message' Message 'Const
root
            case Message' 'Const
msg' of
                RawRpc.Message'abort Exception 'Const
exn ->
                    Cerial 'Const Exception -> LimitT STM Exception
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Exception
Exception 'Const
exn LimitT STM Exception
-> (Exception -> LimitT STM ()) -> LimitT STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ())
-> (Exception -> STM ()) -> Exception -> LimitT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Exception -> STM ()
handleAbortMsg Conn
conn
                RawRpc.Message'unimplemented Message 'Const
oldMsg ->
                    Cerial 'Const Message -> LimitT STM Message
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Message
Message 'Const
oldMsg LimitT STM Message -> (Message -> LimitT STM ()) -> LimitT STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ())
-> (Message -> STM ()) -> Message -> LimitT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Message -> STM ()
handleUnimplementedMsg Conn
conn
                RawRpc.Message'bootstrap Bootstrap 'Const
bs ->
                    Cerial 'Const Bootstrap -> LimitT STM Bootstrap
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Bootstrap
Bootstrap 'Const
bs LimitT STM Bootstrap
-> (Bootstrap -> LimitT STM ()) -> LimitT STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ())
-> (Bootstrap -> STM ()) -> Bootstrap -> LimitT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Bootstrap -> STM ()
handleBootstrapMsg Conn
conn
                RawRpc.Message'call Call 'Const
call ->
                    Conn -> Call 'Const -> LimitT STM ()
handleCallMsg Conn
conn Call 'Const
call
                RawRpc.Message'return Return 'Const
ret -> do
                    Return
ret' <- Conn -> Return 'Const -> LimitT STM Return
acceptReturn Conn
conn Return 'Const
ret
                    STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ()) -> STM () -> LimitT STM ()
forall a b. (a -> b) -> a -> b
$ Conn -> Return -> STM ()
handleReturnMsg Conn
conn Return
ret'
                RawRpc.Message'finish Finish 'Const
finish ->
                    Cerial 'Const Finish -> LimitT STM Finish
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Finish
Finish 'Const
finish LimitT STM Finish -> (Finish -> LimitT STM ()) -> LimitT STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ())
-> (Finish -> STM ()) -> Finish -> LimitT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Finish -> STM ()
handleFinishMsg Conn
conn
                RawRpc.Message'resolve Resolve 'Const
res ->
                    Cerial 'Const Resolve -> LimitT STM Resolve
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Resolve
Resolve 'Const
res LimitT STM Resolve -> (Resolve -> LimitT STM ()) -> LimitT STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ())
-> (Resolve -> STM ()) -> Resolve -> LimitT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Resolve -> STM ()
handleResolveMsg Conn
conn
                RawRpc.Message'release Release 'Const
release ->
                    Cerial 'Const Release -> LimitT STM Release
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Release
Release 'Const
release LimitT STM Release -> (Release -> LimitT STM ()) -> LimitT STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ())
-> (Release -> STM ()) -> Release -> LimitT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Release -> STM ()
handleReleaseMsg Conn
conn
                RawRpc.Message'disembargo Disembargo 'Const
disembargo ->
                    Cerial 'Const Disembargo -> LimitT STM Disembargo
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Disembargo
Disembargo 'Const
disembargo LimitT STM Disembargo
-> (Disembargo -> LimitT STM ()) -> LimitT STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ())
-> (Disembargo -> STM ()) -> Disembargo -> LimitT STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Disembargo -> STM ()
handleDisembargoMsg Conn
conn
                Message' 'Const
_ -> do
                    Message
msg <- Cerial 'Const Message -> LimitT STM Message
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Message
Message 'Const
root
                    STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ()) -> STM () -> LimitT STM ()
forall a b. (a -> b) -> a -> b
$ Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Message -> Message
R.Message'unimplemented Message
msg

-- Each function handle*Msg handles a message of a particular type;
-- 'coordinator' dispatches to these.

handleAbortMsg :: Conn -> R.Exception -> STM ()
handleAbortMsg :: Conn -> Exception -> STM ()
handleAbortMsg Conn
_ Exception
exn =
    RpcError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (Exception -> RpcError
ReceivedAbort Exception
exn)

handleUnimplementedMsg :: Conn -> R.Message -> STM ()
handleUnimplementedMsg :: Conn -> Message -> STM ()
handleUnimplementedMsg Conn
conn Message
msg = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Conn'
conn' -> case Message
msg of
    R.Message'unimplemented Message
_ ->
        -- If the client itself doesn't handle unimplemented messages, that's
        -- weird, but ultimately their problem.
        () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    R.Message'abort Exception
_ ->
        Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
            Text
"Your vat sent an 'unimplemented' message for an abort message " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"that its remote peer never sent. This is likely a bug in your " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"capnproto library."
    Message
_ ->
        Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$
            Text -> Exception
eFailed Text
"Received unimplemented response for required message."

handleBootstrapMsg :: Conn -> R.Bootstrap -> STM ()
handleBootstrapMsg :: Conn -> Bootstrap -> STM ()
handleBootstrapMsg Conn
conn R.Bootstrap{ Word32
$sel:questionId:Bootstrap :: Bootstrap -> Word32
questionId :: Word32
questionId } = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Conn'
conn' -> do
    Return
ret <- case Conn' -> Maybe Client
bootstrap Conn'
conn' of
        Maybe Client
Nothing ->
            Return -> STM Return
forall (f :: * -> *) a. Applicative f => a -> f a
pure Return :: QAId -> Bool -> Return' -> Return
Return
                { $sel:answerId:Return :: QAId
answerId = Word32 -> QAId
QAId Word32
questionId
                , $sel:releaseParamCaps:Return :: Bool
releaseParamCaps = Bool
True -- Not really meaningful for bootstrap, but...
                , $sel:union':Return :: Return'
union' =
                    Exception -> Return'
Return'exception (Exception -> Return') -> Exception -> Return'
forall a b. (a -> b) -> a -> b
$
                        Text -> Exception
eFailed Text
"No bootstrap interface for this connection."
                }
        Just Client
client -> do
            CapDescriptor'
capDesc <- Conn -> Client -> STM CapDescriptor'
emitCap Conn
conn Client
client
            RawMPtr
content <- WordCount
-> (forall s. PureBuilder s (Mutable s RawMPtr)) -> STM RawMPtr
forall (m :: * -> *) a.
(MonadThrow m, Thaw a) =>
WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure WordCount
defaultLimit ((forall s. PureBuilder s (Mutable s RawMPtr)) -> STM RawMPtr)
-> (forall s. PureBuilder s (Mutable s RawMPtr)) -> STM RawMPtr
forall a b. (a -> b) -> a -> b
$ do
                Message ('Mut s)
msg <- Maybe WordCount -> PureBuilder s (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
Message.newMessage Maybe WordCount
forall a. Maybe a
Nothing
                Message ('Mut s)
-> Maybe Ptr -> PureBuilder s (Cerial ('Mut s) (Maybe Ptr))
forall s a (m :: * -> *).
(Cerialize s a, RWCtx m s) =>
Message ('Mut s) -> a -> m (Cerial ('Mut s) a)
cerialize Message ('Mut s)
msg (Maybe Ptr -> PureBuilder s (Cerial ('Mut s) (Maybe Ptr)))
-> Maybe Ptr -> PureBuilder s (Cerial ('Mut s) (Maybe Ptr))
forall a b. (a -> b) -> a -> b
$ Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just (Client -> Ptr
Untyped.PtrCap Client
client)
            Return -> STM Return
forall (f :: * -> *) a. Applicative f => a -> f a
pure Return :: QAId -> Bool -> Return' -> Return
Return
                { $sel:answerId:Return :: QAId
answerId = Word32 -> QAId
QAId Word32
questionId
                , $sel:releaseParamCaps:Return :: Bool
releaseParamCaps = Bool
True -- Not really meaningful for bootstrap, but...
                , $sel:union':Return :: Return'
union' =
                    Payload -> Return'
Return'results Payload :: RawMPtr -> Vector CapDescriptor -> Payload
Payload
                        { RawMPtr
content :: RawMPtr
$sel:content:Payload :: RawMPtr
content
                        , $sel:capTable:Payload :: Vector CapDescriptor
capTable = CapDescriptor -> Vector CapDescriptor
forall a. a -> Vector a
V.singleton (CapDescriptor
forall a. Default a => a
def :: R.CapDescriptor) { $sel:union':CapDescriptor :: CapDescriptor'
R.union' = CapDescriptor'
capDesc }
                        }
                }
    Focus EntryQA STM () -> QAId -> Map QAId EntryQA -> STM ()
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
M.focus
        ((Maybe EntryQA -> STM (Maybe EntryQA)) -> Focus EntryQA STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> m (Maybe a)) -> Focus a m ()
Focus.alterM ((Maybe EntryQA -> STM (Maybe EntryQA)) -> Focus EntryQA STM ())
-> (Maybe EntryQA -> STM (Maybe EntryQA)) -> Focus EntryQA STM ()
forall a b. (a -> b) -> a -> b
$ Conn' -> Return -> Maybe EntryQA -> STM (Maybe EntryQA)
insertBootstrap Conn'
conn' Return
ret)
        (Word32 -> QAId
QAId Word32
questionId)
        (Conn' -> Map QAId EntryQA
answers Conn'
conn')
    Conn' -> Return -> STM ()
sendReturn Conn'
conn' Return
ret
  where
    insertBootstrap :: Conn' -> Return -> Maybe EntryQA -> STM (Maybe EntryQA)
insertBootstrap Conn'
_ Return
ret Maybe EntryQA
Nothing =
        Maybe EntryQA -> STM (Maybe EntryQA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EntryQA -> STM (Maybe EntryQA))
-> Maybe EntryQA -> STM (Maybe EntryQA)
forall a b. (a -> b) -> a -> b
$ EntryQA -> Maybe EntryQA
forall a. a -> Maybe a
Just HaveReturn :: Return -> SnocList (Finish -> STM ()) -> EntryQA
HaveReturn
            { $sel:returnMsg:NewQA :: Return
returnMsg = Return
ret
            , $sel:onFinish:NewQA :: SnocList (Finish -> STM ())
onFinish = [Finish -> STM ()] -> SnocList (Finish -> STM ())
forall a. [a] -> SnocList a
SnocList.fromList
                [ \R.Finish{Bool
releaseResultCaps :: Bool
$sel:releaseResultCaps:Finish :: Finish -> Bool
releaseResultCaps} ->
                    case Return
ret of
                        Return
                            { $sel:union':Return :: Return -> Return'
union' = Return'results Payload
                                { $sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable = (Vector CapDescriptor -> [CapDescriptor]
forall a. Vector a -> [a]
V.toList -> [ R.CapDescriptor { $sel:union':CapDescriptor :: CapDescriptor -> CapDescriptor'
union' = R.CapDescriptor'receiverHosted (Word32 -> IEId
IEId -> IEId
eid) } ])
                                }
                            } ->
                                Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
releaseResultCaps (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
                                    Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Word32
1 IEId
eid
                        Return
_ ->
                            () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                ]

            }
    insertBootstrap Conn'
conn' Return
_ (Just EntryQA
_) =
        Conn' -> Exception -> STM (Maybe EntryQA)
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM (Maybe EntryQA))
-> Exception -> STM (Maybe EntryQA)
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed Text
"Duplicate question ID"

handleCallMsg :: Conn -> RawRpc.Call 'Const -> LimitT STM ()
handleCallMsg :: Conn -> Call 'Const -> LimitT STM ()
handleCallMsg Conn
conn Call 'Const
callMsg = do
    conn' :: Conn'
conn'@Conn'{Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports, Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} <- STM Conn' -> LimitT STM Conn'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM Conn' -> LimitT STM Conn') -> STM Conn' -> LimitT STM Conn'
forall a b. (a -> b) -> a -> b
$ Conn -> STM Conn'
getLive Conn
conn
    Word32
questionId <- Call 'Const -> LimitT STM Word32
forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Call msg -> m Word32
RawRpc.get_Call'questionId Call 'Const
callMsg
    MessageTarget
target <- Call 'Const -> LimitT STM (MessageTarget 'Const)
forall (m :: * -> *) (msg :: Mutability).
(ReadCtx m msg, FromPtr msg (MessageTarget msg)) =>
Call msg -> m (MessageTarget msg)
RawRpc.get_Call'target Call 'Const
callMsg LimitT STM (MessageTarget 'Const)
-> (MessageTarget 'Const -> LimitT STM MessageTarget)
-> LimitT STM MessageTarget
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageTarget 'Const -> LimitT STM MessageTarget
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize
    Word64
interfaceId <- Call 'Const -> LimitT STM Word64
forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Call msg -> m Word64
RawRpc.get_Call'interfaceId Call 'Const
callMsg
    Word16
methodId <- Call 'Const -> LimitT STM Word16
forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Call msg -> m Word16
RawRpc.get_Call'methodId Call 'Const
callMsg
    Payload 'Const
payload <- Call 'Const -> LimitT STM (Payload 'Const)
forall (m :: * -> *) (msg :: Mutability).
(ReadCtx m msg, FromPtr msg (Payload msg)) =>
Call msg -> m (Payload msg)
RawRpc.get_Call'params Call 'Const
callMsg

    Payload{$sel:content:Payload :: Payload -> RawMPtr
content = RawMPtr
callParams, Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable} <- Conn -> Payload 'Const -> LimitT STM Payload
acceptPayload Conn
conn Payload 'Const
payload

    STM () -> LimitT STM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM () -> LimitT STM ()) -> STM () -> LimitT STM ()
forall a b. (a -> b) -> a -> b
$ do
        -- First, add an entry in our answers table:
        Text -> Conn' -> QAId -> EntryQA -> Map QAId EntryQA -> STM ()
forall k v.
(Eq k, Hashable k) =>
Text -> Conn' -> k -> v -> Map k v -> STM ()
insertNewAbort
            Text
"answer"
            Conn'
conn'
            (Word32 -> QAId
QAId Word32
questionId)
            NewQA :: SnocList (Finish -> STM ())
-> SnocList (Return -> STM ()) -> EntryQA
NewQA
                { $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn = SnocList (Return -> STM ())
forall a. SnocList a
SnocList.empty
                , $sel:onFinish:NewQA :: SnocList (Finish -> STM ())
onFinish = [Finish -> STM ()] -> SnocList (Finish -> STM ())
forall a. [a] -> SnocList a
SnocList.fromList
                    [ \R.Finish{Bool
releaseResultCaps :: Bool
$sel:releaseResultCaps:Finish :: Finish -> Bool
releaseResultCaps} ->
                        Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
releaseResultCaps (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
                            Vector CapDescriptor -> (CapDescriptor -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Vector CapDescriptor
capTable ((CapDescriptor -> STM ()) -> STM ())
-> (CapDescriptor -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \R.CapDescriptor{CapDescriptor'
union' :: CapDescriptor'
$sel:union':CapDescriptor :: CapDescriptor -> CapDescriptor'
union'} -> case CapDescriptor'
union' of
                                R.CapDescriptor'receiverHosted (Word32 -> IEId
IEId -> IEId
importId) ->
                                    Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Word32
1 IEId
importId
                                CapDescriptor'
_ ->
                                    () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    ]
                }
            Map QAId EntryQA
answers

        -- Set up a callback for when the call is finished, to
        -- send the return message:
        Fulfiller RawMPtr
fulfiller <- (Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr)
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr))
-> (Either Exception RawMPtr -> STM ()) -> STM (Fulfiller RawMPtr)
forall a b. (a -> b) -> a -> b
$ \case
            Left Exception
e ->
                Conn' -> Return -> STM ()
returnAnswer Conn'
conn' Return :: QAId -> Bool -> Return' -> Return
Return
                    { $sel:answerId:Return :: QAId
answerId = Word32 -> QAId
QAId Word32
questionId
                    , $sel:releaseParamCaps:Return :: Bool
releaseParamCaps = Bool
False
                    , $sel:union':Return :: Return'
union' = Exception -> Return'
Return'exception Exception
e
                    }
            Right RawMPtr
content -> do
                Vector CapDescriptor
capTable <- Conn -> RawMPtr -> STM (Vector CapDescriptor)
genSendableCapTableRaw Conn
conn RawMPtr
content
                Conn' -> Return -> STM ()
returnAnswer Conn'
conn' Return :: QAId -> Bool -> Return' -> Return
Return
                    { $sel:answerId:Return :: QAId
answerId = Word32 -> QAId
QAId Word32
questionId
                    , $sel:releaseParamCaps:Return :: Bool
releaseParamCaps = Bool
False
                    , $sel:union':Return :: Return'
union'   = Payload -> Return'
Return'results Payload :: RawMPtr -> Vector CapDescriptor -> Payload
Payload
                        { $sel:content:Payload :: RawMPtr
content  = RawMPtr
content
                        , $sel:capTable:Payload :: Vector CapDescriptor
capTable = Vector CapDescriptor
capTable
                        }
                    }
        -- Package up the info for the call:
        let callInfo :: CallInfo
callInfo = CallInfo :: Word64 -> Word16 -> RawMPtr -> Fulfiller RawMPtr -> CallInfo
Server.CallInfo
                { Word64
interfaceId :: Word64
interfaceId :: Word64
interfaceId
                , Word16
methodId :: Word16
methodId :: Word16
methodId
                , arguments :: RawMPtr
arguments = RawMPtr
callParams
                , response :: Fulfiller RawMPtr
response = Fulfiller RawMPtr
fulfiller
                }
        -- Finally, figure out where to send it:
        case MessageTarget
target of
            R.MessageTarget'importedCap Word32
exportId ->
                Text
-> Conn' -> Map IEId EntryE -> IEId -> (EntryE -> STM ()) -> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
"export" Conn'
conn' Map IEId EntryE
exports (Word32 -> IEId
IEId Word32
exportId) ((EntryE -> STM ()) -> STM ()) -> (EntryE -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$
                    \EntryE{Client'
client :: Client'
$sel:client:EntryE :: EntryE -> Client'
client} -> STM Pipeline -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Pipeline -> STM ()) -> STM Pipeline -> STM ()
forall a b. (a -> b) -> a -> b
$ CallInfo -> Client -> STM Pipeline
forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m Pipeline
call CallInfo
callInfo (Client -> STM Pipeline) -> Client -> STM Pipeline
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just Client'
client
            R.MessageTarget'promisedAnswer R.PromisedAnswer { $sel:questionId:PromisedAnswer :: PromisedAnswer -> Word32
questionId = Word32
targetQid, Vector PromisedAnswer'Op
transform :: Vector PromisedAnswer'Op
$sel:transform:PromisedAnswer :: PromisedAnswer -> Vector PromisedAnswer'Op
transform } ->
                let onReturn :: Return -> STM ()
onReturn ret :: Return
ret@Return{Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union'} =
                        case Return'
union' of
                            Return'exception Exception
_ ->
                                Conn' -> Return -> STM ()
returnAnswer Conn'
conn' Return
ret { $sel:answerId:Return :: QAId
answerId = Word32 -> QAId
QAId Word32
questionId }
                            Return'
Return'canceled ->
                                Conn' -> Return -> STM ()
returnAnswer Conn'
conn' Return
ret { $sel:answerId:Return :: QAId
answerId = Word32 -> QAId
QAId Word32
questionId }
                            Return'results Payload{RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content} ->
                                STM Pipeline -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Pipeline -> STM ()) -> STM Pipeline -> STM ()
forall a b. (a -> b) -> a -> b
$ Vector PromisedAnswer'Op -> RawMPtr -> Conn' -> STM Client
transformClient Vector PromisedAnswer'Op
transform RawMPtr
content Conn'
conn' STM Client -> (Client -> STM Pipeline) -> STM Pipeline
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CallInfo -> Client -> STM Pipeline
forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m Pipeline
call CallInfo
callInfo
                            Return'
Return'resultsSentElsewhere ->
                                -- our implementation should never actually do this, but
                                -- this way we don't have to change this if/when we
                                -- support the feature:
                                Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                                    Text
"Tried to call a method on a promised answer that " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                    Text
"returned resultsSentElsewhere"
                            Return'takeFromOtherQuestion QAId
otherQid ->
                                Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"answer" Conn'
conn' Map QAId EntryQA
answers QAId
otherQid Return -> STM ()
onReturn
                            Return'acceptFromThirdParty RawMPtr
_ ->
                                -- Note [Level 3]
                                String -> STM ()
forall a. HasCallStack => String -> a
error String
"BUG: our implementation unexpectedly used a level 3 feature"
                in
                Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"answer" Conn'
conn' Map QAId EntryQA
answers (Word32 -> QAId
QAId Word32
targetQid) Return -> STM ()
onReturn
            R.MessageTarget'unknown' Word16
ordinal ->
                Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eUnimplemented (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                    Text
"Unknown MessageTarget ordinal #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word16 -> String
forall a. Show a => a -> String
show Word16
ordinal)

ptrPathClient :: MonadThrow m => [Word16] -> RawMPtr -> m Client
ptrPathClient :: [Word16] -> RawMPtr -> m Client
ptrPathClient [Word16]
is RawMPtr
ptr =
    WordCount -> LimitT m Client -> m Client
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT m Client -> m Client) -> LimitT m Client -> m Client
forall a b. (a -> b) -> a -> b
$ [Word16] -> RawMPtr -> LimitT m RawMPtr
forall (m :: * -> *).
ReadCtx m 'Const =>
[Word16] -> RawMPtr -> m RawMPtr
followPtrs [Word16]
is RawMPtr
ptr LimitT m RawMPtr -> (RawMPtr -> LimitT m Client) -> LimitT m Client
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawMPtr -> LimitT m Client
forall (m :: * -> *). ReadCtx m 'Const => RawMPtr -> m Client
ptrClient

transformClient :: V.Vector R.PromisedAnswer'Op -> RawMPtr -> Conn' -> STM Client
transformClient :: Vector PromisedAnswer'Op -> RawMPtr -> Conn' -> STM Client
transformClient Vector PromisedAnswer'Op
transform RawMPtr
ptr Conn'
conn =
    ([PromisedAnswer'Op] -> STM [Word16]
forall (m :: * -> *).
MonadThrow m =>
[PromisedAnswer'Op] -> m [Word16]
unmarshalOps (Vector PromisedAnswer'Op -> [PromisedAnswer'Op]
forall a. Vector a -> [a]
V.toList Vector PromisedAnswer'Op
transform) STM [Word16] -> ([Word16] -> STM Client) -> STM Client
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Word16] -> RawMPtr -> STM Client)
-> RawMPtr -> [Word16] -> STM Client
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Word16] -> RawMPtr -> STM Client
forall (m :: * -> *).
MonadThrow m =>
[Word16] -> RawMPtr -> m Client
ptrPathClient RawMPtr
ptr)
        STM Client -> (Exception -> STM Client) -> STM Client
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
`catchSTM` Conn' -> Exception -> STM Client
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn

ptrClient :: UntypedRaw.ReadCtx m 'Const => RawMPtr -> m Client
ptrClient :: RawMPtr -> m Client
ptrClient RawMPtr
Nothing = Client -> m Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
nullClient
ptrClient (Just (UntypedRaw.PtrCap Cap 'Const
cap)) = Cap 'Const -> m Client
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
UntypedRaw.getClient Cap 'Const
cap
ptrClient (Just Ptr 'Const
_) = Exception -> m Client
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Exception -> m Client) -> Exception -> m Client
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed Text
"Tried to call method on non-capability."

-- | Follow a series of pointer indicies, returning the final value, or 'Left'
-- with an error if any of the pointers in the chain (except the last one) is
-- a non-null non struct.
followPtrs :: UntypedRaw.ReadCtx m 'Const => [Word16] -> RawMPtr -> m RawMPtr
followPtrs :: [Word16] -> RawMPtr -> m RawMPtr
followPtrs [] RawMPtr
ptr =
    RawMPtr -> m RawMPtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawMPtr
ptr
followPtrs (Word16
_:[Word16]
_) RawMPtr
Nothing =
    RawMPtr -> m RawMPtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawMPtr
forall a. Maybe a
Nothing
followPtrs (Word16
i:[Word16]
is) (Just (UntypedRaw.PtrStruct Struct 'Const
struct)) =
    Int -> Struct 'Const -> m RawMPtr
forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m (Maybe (Ptr msg))
UntypedRaw.getPtr (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i) Struct 'Const
struct m RawMPtr -> (RawMPtr -> m RawMPtr) -> m RawMPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Word16] -> RawMPtr -> m RawMPtr
forall (m :: * -> *).
ReadCtx m 'Const =>
[Word16] -> RawMPtr -> m RawMPtr
followPtrs [Word16]
is
followPtrs (Word16
_:[Word16]
_) (Just Ptr 'Const
_) =
    Exception -> m RawMPtr
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Exception -> m RawMPtr) -> Exception -> m RawMPtr
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed Text
"Tried to access pointer field of non-struct."

sendRawMsg :: Conn' -> Message 'Const -> STM ()
sendRawMsg :: Conn' -> Message 'Const -> STM ()
sendRawMsg Conn'
conn' = TBQueue (Message 'Const) -> Message 'Const -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (Conn' -> TBQueue (Message 'Const)
sendQ Conn'
conn')

sendCall :: Conn' -> Call -> STM ()
sendCall :: Conn' -> Call -> STM ()
sendCall Conn'
conn' Call{QAId
questionId :: QAId
$sel:questionId:Call :: Call -> QAId
questionId, MsgTarget
target :: MsgTarget
$sel:target:Call :: Call -> MsgTarget
target, Word64
interfaceId :: Word64
$sel:interfaceId:Call :: Call -> Word64
interfaceId, Word16
methodId :: Word16
$sel:methodId:Call :: Call -> Word16
methodId, $sel:params:Call :: Call -> Payload
params=Payload{RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content, Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable}} =
    Conn' -> Message 'Const -> STM ()
sendRawMsg Conn'
conn' (Message 'Const -> STM ()) -> STM (Message 'Const) -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< WordCount
-> (forall s. PureBuilder s (Mutable s (Message 'Const)))
-> STM (Message 'Const)
forall (m :: * -> *) a.
(MonadThrow m, Thaw a) =>
WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure WordCount
defaultLimit (do
        Maybe (Ptr ('Mut s))
mcontent <- RawMPtr -> PureBuilder s (Mutable s RawMPtr)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
thaw RawMPtr
content
        Message ('Mut s)
msg <- case Maybe (Ptr ('Mut s))
mcontent of
            Just Ptr ('Mut s)
v  -> Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message ('Mut s) -> PureBuilder s (Message ('Mut s)))
-> Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall a b. (a -> b) -> a -> b
$ Ptr ('Mut s) -> Message ('Mut s)
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
UntypedRaw.message Ptr ('Mut s)
v
            Maybe (Ptr ('Mut s))
Nothing -> Maybe WordCount -> PureBuilder s (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
Message.newMessage Maybe WordCount
forall a. Maybe a
Nothing
        List ('Mut s) (CapDescriptor ('Mut s))
mcapTable <- Message ('Mut s)
-> Vector CapDescriptor
-> PureBuilder s (Cerial ('Mut s) (Vector CapDescriptor))
forall s a (m :: * -> *).
(Cerialize s a, RWCtx m s) =>
Message ('Mut s) -> a -> m (Cerial ('Mut s) a)
cerialize Message ('Mut s)
msg Vector CapDescriptor
capTable
        Payload ('Mut s)
payload <- Message ('Mut s) -> PureBuilder s (Payload ('Mut s))
forall s e (m :: * -> *).
(Allocate s e, WriteCtx m s) =>
Message ('Mut s) -> m e
new Message ('Mut s)
msg
        Payload ('Mut s) -> Maybe (Ptr ('Mut s)) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (Maybe (Ptr ('Mut s)))) =>
Payload ('Mut s) -> Maybe (Ptr ('Mut s)) -> m ()
RawRpc.set_Payload'content Payload ('Mut s)
payload Maybe (Ptr ('Mut s))
mcontent
        Payload ('Mut s)
-> List ('Mut s) (CapDescriptor ('Mut s)) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (List ('Mut s) (CapDescriptor ('Mut s)))) =>
Payload ('Mut s) -> List ('Mut s) (CapDescriptor ('Mut s)) -> m ()
RawRpc.set_Payload'capTable Payload ('Mut s)
payload List ('Mut s) (CapDescriptor ('Mut s))
mcapTable
        Call ('Mut s)
call <- Message ('Mut s) -> PureBuilder s (Call ('Mut s))
forall s e (m :: * -> *).
(Allocate s e, WriteCtx m s) =>
Message ('Mut s) -> m e
new Message ('Mut s)
msg
        Call ('Mut s) -> Payload ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (Payload ('Mut s))) =>
Call ('Mut s) -> Payload ('Mut s) -> m ()
RawRpc.set_Call'params Call ('Mut s)
call Payload ('Mut s)
payload
        Call ('Mut s) -> Word32 -> PureBuilder s ()
forall (m :: * -> *) s.
RWCtx m s =>
Call ('Mut s) -> Word32 -> m ()
RawRpc.set_Call'questionId Call ('Mut s)
call (QAId -> Word32
qaWord QAId
questionId)
        Call ('Mut s) -> Word64 -> PureBuilder s ()
forall (m :: * -> *) s.
RWCtx m s =>
Call ('Mut s) -> Word64 -> m ()
RawRpc.set_Call'interfaceId Call ('Mut s)
call Word64
interfaceId
        Call ('Mut s) -> Word16 -> PureBuilder s ()
forall (m :: * -> *) s.
RWCtx m s =>
Call ('Mut s) -> Word16 -> m ()
RawRpc.set_Call'methodId Call ('Mut s)
call Word16
methodId
        MessageTarget ('Mut s)
tgt <- Message ('Mut s)
-> MessageTarget -> PureBuilder s (Cerial ('Mut s) MessageTarget)
forall s a (m :: * -> *).
(Cerialize s a, RWCtx m s) =>
Message ('Mut s) -> a -> m (Cerial ('Mut s) a)
cerialize Message ('Mut s)
msg (MessageTarget -> PureBuilder s (Cerial ('Mut s) MessageTarget))
-> MessageTarget -> PureBuilder s (Cerial ('Mut s) MessageTarget)
forall a b. (a -> b) -> a -> b
$ MsgTarget -> MessageTarget
marshalMsgTarget MsgTarget
target
        Call ('Mut s) -> MessageTarget ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (MessageTarget ('Mut s))) =>
Call ('Mut s) -> MessageTarget ('Mut s) -> m ()
RawRpc.set_Call'target Call ('Mut s)
call MessageTarget ('Mut s)
tgt
        Message ('Mut s)
rpcMsg <- Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall s e (m :: * -> *).
(Allocate s e, WriteCtx m s) =>
Message ('Mut s) -> m e
new Message ('Mut s)
msg
        Message ('Mut s) -> Call ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (Call ('Mut s))) =>
Message ('Mut s) -> Call ('Mut s) -> m ()
RawRpc.set_Message'call Message ('Mut s)
rpcMsg Call ('Mut s)
call
        Struct ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
UntypedRaw.setRoot (Message ('Mut s) -> Struct ('Mut s)
forall (mut :: Mutability) a. ToStruct mut a => a -> Struct mut
toStruct Message ('Mut s)
rpcMsg)
        Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message ('Mut s)
msg
    )

sendReturn :: Conn' -> Return -> STM ()
sendReturn :: Conn' -> Return -> STM ()
sendReturn Conn'
conn' Return{QAId
answerId :: QAId
$sel:answerId:Return :: Return -> QAId
answerId, Bool
releaseParamCaps :: Bool
$sel:releaseParamCaps:Return :: Return -> Bool
releaseParamCaps, Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union'} = case Return'
union' of
    Return'results Payload{RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content, Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable} ->
        Conn' -> Message 'Const -> STM ()
sendRawMsg Conn'
conn' (Message 'Const -> STM ()) -> STM (Message 'Const) -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< WordCount
-> (forall s. PureBuilder s (Mutable s (Message 'Const)))
-> STM (Message 'Const)
forall (m :: * -> *) a.
(MonadThrow m, Thaw a) =>
WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure WordCount
defaultLimit (do
            Maybe (Ptr ('Mut s))
mcontent <- RawMPtr -> PureBuilder s (Mutable s RawMPtr)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
thaw RawMPtr
content
            Message ('Mut s)
msg <- case Maybe (Ptr ('Mut s))
mcontent of
                Just Ptr ('Mut s)
v  -> Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message ('Mut s) -> PureBuilder s (Message ('Mut s)))
-> Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall a b. (a -> b) -> a -> b
$ Ptr ('Mut s) -> Message ('Mut s)
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
UntypedRaw.message Ptr ('Mut s)
v
                Maybe (Ptr ('Mut s))
Nothing -> Maybe WordCount -> PureBuilder s (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
Message.newMessage Maybe WordCount
forall a. Maybe a
Nothing
            List ('Mut s) (CapDescriptor ('Mut s))
mcapTable <- Message ('Mut s)
-> Vector CapDescriptor
-> PureBuilder s (Cerial ('Mut s) (Vector CapDescriptor))
forall s a (m :: * -> *).
(Cerialize s a, RWCtx m s) =>
Message ('Mut s) -> a -> m (Cerial ('Mut s) a)
cerialize Message ('Mut s)
msg Vector CapDescriptor
capTable
            Payload ('Mut s)
payload <- Message ('Mut s) -> PureBuilder s (Payload ('Mut s))
forall s e (m :: * -> *).
(Allocate s e, WriteCtx m s) =>
Message ('Mut s) -> m e
new Message ('Mut s)
msg
            Payload ('Mut s) -> Maybe (Ptr ('Mut s)) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (Maybe (Ptr ('Mut s)))) =>
Payload ('Mut s) -> Maybe (Ptr ('Mut s)) -> m ()
RawRpc.set_Payload'content Payload ('Mut s)
payload Maybe (Ptr ('Mut s))
mcontent
            Payload ('Mut s)
-> List ('Mut s) (CapDescriptor ('Mut s)) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (List ('Mut s) (CapDescriptor ('Mut s)))) =>
Payload ('Mut s) -> List ('Mut s) (CapDescriptor ('Mut s)) -> m ()
RawRpc.set_Payload'capTable Payload ('Mut s)
payload List ('Mut s) (CapDescriptor ('Mut s))
mcapTable
            Return ('Mut s)
ret <- Message ('Mut s) -> PureBuilder s (Return ('Mut s))
forall s e (m :: * -> *).
(Allocate s e, WriteCtx m s) =>
Message ('Mut s) -> m e
new Message ('Mut s)
msg
            Return ('Mut s) -> Payload ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (Payload ('Mut s))) =>
Return ('Mut s) -> Payload ('Mut s) -> m ()
RawRpc.set_Return'results Return ('Mut s)
ret Payload ('Mut s)
payload
            Return ('Mut s) -> Word32 -> PureBuilder s ()
forall (m :: * -> *) s.
RWCtx m s =>
Return ('Mut s) -> Word32 -> m ()
RawRpc.set_Return'answerId Return ('Mut s)
ret (QAId -> Word32
qaWord QAId
answerId)
            Return ('Mut s) -> Bool -> PureBuilder s ()
forall (m :: * -> *) s.
RWCtx m s =>
Return ('Mut s) -> Bool -> m ()
RawRpc.set_Return'releaseParamCaps Return ('Mut s)
ret Bool
releaseParamCaps
            Message ('Mut s)
rpcMsg <- Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall s e (m :: * -> *).
(Allocate s e, WriteCtx m s) =>
Message ('Mut s) -> m e
new Message ('Mut s)
msg
            Message ('Mut s) -> Return ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (Return ('Mut s))) =>
Message ('Mut s) -> Return ('Mut s) -> m ()
RawRpc.set_Message'return Message ('Mut s)
rpcMsg Return ('Mut s)
ret
            Struct ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
UntypedRaw.setRoot (Message ('Mut s) -> Struct ('Mut s)
forall (mut :: Mutability) a. ToStruct mut a => a -> Struct mut
toStruct Message ('Mut s)
rpcMsg)
            Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message ('Mut s)
msg
        )
    Return'exception Exception
exn ->
        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Return -> Message
R.Message'return Return :: Word32 -> Bool -> Return' -> Return
R.Return
            { $sel:answerId:Return :: Word32
answerId = QAId -> Word32
qaWord QAId
answerId
            , Bool
$sel:releaseParamCaps:Return :: Bool
releaseParamCaps :: Bool
releaseParamCaps
            , $sel:union':Return :: Return'
union' = Exception -> Return'
R.Return'exception Exception
exn
            }
    Return'
Return'canceled ->
        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Return -> Message
R.Message'return Return :: Word32 -> Bool -> Return' -> Return
R.Return
            { $sel:answerId:Return :: Word32
answerId = QAId -> Word32
qaWord QAId
answerId
            , Bool
$sel:releaseParamCaps:Return :: Bool
releaseParamCaps :: Bool
releaseParamCaps
            , $sel:union':Return :: Return'
union' = Return'
R.Return'canceled
            }
    Return'
Return'resultsSentElsewhere ->
        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Return -> Message
R.Message'return Return :: Word32 -> Bool -> Return' -> Return
R.Return
            { $sel:answerId:Return :: Word32
answerId = QAId -> Word32
qaWord QAId
answerId
            , Bool
$sel:releaseParamCaps:Return :: Bool
releaseParamCaps :: Bool
releaseParamCaps
            , $sel:union':Return :: Return'
union' = Return'
R.Return'resultsSentElsewhere
            }
    Return'takeFromOtherQuestion (QAId Word32
qid) ->
        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Return -> Message
R.Message'return Return :: Word32 -> Bool -> Return' -> Return
R.Return
            { $sel:answerId:Return :: Word32
answerId = QAId -> Word32
qaWord QAId
answerId
            , Bool
$sel:releaseParamCaps:Return :: Bool
releaseParamCaps :: Bool
releaseParamCaps
            , $sel:union':Return :: Return'
union' = Word32 -> Return'
R.Return'takeFromOtherQuestion Word32
qid
            }
    Return'acceptFromThirdParty RawMPtr
ptr ->
        Conn' -> Message 'Const -> STM ()
sendRawMsg Conn'
conn' (Message 'Const -> STM ()) -> STM (Message 'Const) -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< WordCount
-> (forall s. PureBuilder s (Mutable s (Message 'Const)))
-> STM (Message 'Const)
forall (m :: * -> *) a.
(MonadThrow m, Thaw a) =>
WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure WordCount
defaultLimit (do
            Maybe (Ptr ('Mut s))
mptr <- RawMPtr -> PureBuilder s (Mutable s RawMPtr)
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
a -> m (Mutable s a)
thaw RawMPtr
ptr
            Message ('Mut s)
msg <- case Maybe (Ptr ('Mut s))
mptr of
                Just Ptr ('Mut s)
v  -> Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message ('Mut s) -> PureBuilder s (Message ('Mut s)))
-> Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall a b. (a -> b) -> a -> b
$ Ptr ('Mut s) -> Message ('Mut s)
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
UntypedRaw.message Ptr ('Mut s)
v
                Maybe (Ptr ('Mut s))
Nothing -> Maybe WordCount -> PureBuilder s (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
Message.newMessage Maybe WordCount
forall a. Maybe a
Nothing
            Return ('Mut s)
ret <- Message ('Mut s) -> PureBuilder s (Return ('Mut s))
forall s e (m :: * -> *).
(Allocate s e, WriteCtx m s) =>
Message ('Mut s) -> m e
new Message ('Mut s)
msg
            Return ('Mut s) -> Word32 -> PureBuilder s ()
forall (m :: * -> *) s.
RWCtx m s =>
Return ('Mut s) -> Word32 -> m ()
RawRpc.set_Return'answerId Return ('Mut s)
ret (QAId -> Word32
qaWord QAId
answerId)
            Return ('Mut s) -> Bool -> PureBuilder s ()
forall (m :: * -> *) s.
RWCtx m s =>
Return ('Mut s) -> Bool -> m ()
RawRpc.set_Return'releaseParamCaps Return ('Mut s)
ret Bool
releaseParamCaps
            Return ('Mut s) -> Maybe (Ptr ('Mut s)) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (Maybe (Ptr ('Mut s)))) =>
Return ('Mut s) -> Maybe (Ptr ('Mut s)) -> m ()
RawRpc.set_Return'acceptFromThirdParty Return ('Mut s)
ret Maybe (Ptr ('Mut s))
mptr
            Message ('Mut s)
rpcMsg <- Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall s e (m :: * -> *).
(Allocate s e, WriteCtx m s) =>
Message ('Mut s) -> m e
new Message ('Mut s)
msg
            Message ('Mut s) -> Return ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s.
(RWCtx m s, ToPtr s (Return ('Mut s))) =>
Message ('Mut s) -> Return ('Mut s) -> m ()
RawRpc.set_Message'return Message ('Mut s)
rpcMsg Return ('Mut s)
ret
            Struct ('Mut s) -> PureBuilder s ()
forall (m :: * -> *) s. WriteCtx m s => Struct ('Mut s) -> m ()
UntypedRaw.setRoot (Message ('Mut s) -> Struct ('Mut s)
forall (mut :: Mutability) a. ToStruct mut a => a -> Struct mut
toStruct Message ('Mut s)
rpcMsg)
            Message ('Mut s) -> PureBuilder s (Message ('Mut s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message ('Mut s)
msg
        )

acceptReturn :: Conn -> RawRpc.Return 'Const -> LimitT STM Return
acceptReturn :: Conn -> Return 'Const -> LimitT STM Return
acceptReturn Conn
conn Return 'Const
ret = do
    QAId
answerId <- Word32 -> QAId
QAId (Word32 -> QAId) -> LimitT STM Word32 -> LimitT STM QAId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Return 'Const -> LimitT STM Word32
forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Return msg -> m Word32
RawRpc.get_Return'answerId Return 'Const
ret
    Bool
releaseParamCaps <- Return 'Const -> LimitT STM Bool
forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Return msg -> m Bool
RawRpc.get_Return'releaseParamCaps Return 'Const
ret
    Return' 'Const
ret' <- Return 'Const -> LimitT STM (Return' 'Const)
forall (m :: * -> *) (msg :: Mutability).
(ReadCtx m msg, FromStruct msg (Return' msg)) =>
Return msg -> m (Return' msg)
RawRpc.get_Return' Return 'Const
ret
    Return'
union' <- case Return' 'Const
ret' of
        RawRpc.Return'results Payload 'Const
payload ->
            Payload -> Return'
Return'results (Payload -> Return') -> LimitT STM Payload -> LimitT STM Return'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conn -> Payload 'Const -> LimitT STM Payload
acceptPayload Conn
conn Payload 'Const
payload
        RawRpc.Return'exception Exception 'Const
exn ->
            Exception -> Return'
Return'exception (Exception -> Return')
-> LimitT STM Exception -> LimitT STM Return'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cerial 'Const Exception -> LimitT STM Exception
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize Cerial 'Const Exception
Exception 'Const
exn
        Return' 'Const
RawRpc.Return'canceled ->
            Return' -> LimitT STM Return'
forall (f :: * -> *) a. Applicative f => a -> f a
pure Return'
Return'canceled
        Return' 'Const
RawRpc.Return'resultsSentElsewhere ->
            Return' -> LimitT STM Return'
forall (f :: * -> *) a. Applicative f => a -> f a
pure Return'
Return'resultsSentElsewhere
        RawRpc.Return'takeFromOtherQuestion Word32
id ->
            Return' -> LimitT STM Return'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Return' -> LimitT STM Return') -> Return' -> LimitT STM Return'
forall a b. (a -> b) -> a -> b
$ QAId -> Return'
Return'takeFromOtherQuestion (Word32 -> QAId
QAId Word32
id)
        RawRpc.Return'acceptFromThirdParty RawMPtr
ptr ->
            Return' -> LimitT STM Return'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Return' -> LimitT STM Return') -> Return' -> LimitT STM Return'
forall a b. (a -> b) -> a -> b
$ RawMPtr -> Return'
Return'acceptFromThirdParty RawMPtr
ptr
        RawRpc.Return'unknown' Word16
ordinal ->
            STM Return' -> LimitT STM Return'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM Return' -> LimitT STM Return')
-> STM Return' -> LimitT STM Return'
forall a b. (a -> b) -> a -> b
$ Exception -> STM Return'
forall e a. Exception e => e -> STM a
throwSTM (Exception -> STM Return') -> Exception -> STM Return'
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ Text
"Unknown return variant #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word16 -> String
forall a. Show a => a -> String
show Word16
ordinal)
    Return -> LimitT STM Return
forall (f :: * -> *) a. Applicative f => a -> f a
pure Return :: QAId -> Bool -> Return' -> Return
Return { QAId
answerId :: QAId
$sel:answerId:Return :: QAId
answerId, Bool
releaseParamCaps :: Bool
$sel:releaseParamCaps:Return :: Bool
releaseParamCaps, Return'
union' :: Return'
$sel:union':Return :: Return'
union' }

handleReturnMsg :: Conn -> Return -> STM ()
handleReturnMsg :: Conn -> Return -> STM ()
handleReturnMsg Conn
conn Return
ret = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \conn' :: Conn'
conn'@Conn'{Map QAId EntryQA
questions :: Map QAId EntryQA
$sel:questions:Conn' :: Conn' -> Map QAId EntryQA
questions} ->
    Conn' -> Map QAId EntryQA -> Text -> Return -> STM ()
updateQAReturn Conn'
conn' Map QAId EntryQA
questions Text
"question" Return
ret

handleFinishMsg :: Conn -> R.Finish -> STM ()
handleFinishMsg :: Conn -> Finish -> STM ()
handleFinishMsg Conn
conn Finish
finish = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \conn' :: Conn'
conn'@Conn'{Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} ->
    Conn' -> Map QAId EntryQA -> Text -> Finish -> STM ()
updateQAFinish Conn'
conn' Map QAId EntryQA
answers Text
"answer" Finish
finish

handleResolveMsg :: Conn -> R.Resolve -> STM ()
handleResolveMsg :: Conn -> Resolve -> STM ()
handleResolveMsg Conn
conn R.Resolve{Word32
$sel:promiseId:Resolve :: Resolve -> Word32
promiseId :: Word32
promiseId, Resolve'
$sel:union':Resolve :: Resolve -> Resolve'
union' :: Resolve'
union'} =
    Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \conn' :: Conn'
conn'@Conn'{Map IEId EntryI
imports :: Map IEId EntryI
$sel:imports:Conn' :: Conn' -> Map IEId EntryI
imports} -> do
        Maybe EntryI
entry <- IEId -> Map IEId EntryI -> STM (Maybe EntryI)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup (Word32 -> IEId
IEId Word32
promiseId) Map IEId EntryI
imports
        case Maybe EntryI
entry of
            Maybe EntryI
Nothing ->
                -- This can happen if we dropped the promise, but the release
                -- message is still in flight when the resolve message is sent.
                case Resolve'
union' of
                    R.Resolve'cap R.CapDescriptor{$sel:union':CapDescriptor :: CapDescriptor -> CapDescriptor'
union' = R.CapDescriptor'receiverHosted Word32
importId} ->
                        -- Send a release message for the resolved cap, since
                        -- we're not going to use it:
                        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Release -> Message
R.Message'release Release
forall a. Default a => a
def
                            { $sel:id:Release :: Word32
R.id = Word32
importId
                            , $sel:referenceCount:Release :: Word32
R.referenceCount = Word32
1
                            }
                    -- Note [Level 3]: do we need to do something with
                    -- thirdPartyHosted here?
                    Resolve'
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just EntryI{ $sel:promiseState:EntryI :: EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState = Maybe (TVar PromiseState, TmpDest)
Nothing } ->
                -- This wasn't a promise! The remote vat has done something wrong;
                -- abort the connection.
                Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                    [ Text
"Received a resolve message for export id #", String -> Text
forall a. IsString a => String -> a
fromString (Word32 -> String
forall a. Show a => a -> String
show Word32
promiseId)
                    , Text
", but that capability is not a promise!"
                    ]
            Just EntryI { $sel:promiseState:EntryI :: EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState = Just (TVar PromiseState
tvar, TmpDest
tmpDest) } ->
                case Resolve'
union' of
                    R.Resolve'cap R.CapDescriptor{$sel:union':CapDescriptor :: CapDescriptor -> CapDescriptor'
union' = CapDescriptor'
cap} -> do
                        Client
client <- Conn -> CapDescriptor' -> STM Client
acceptCap Conn
conn CapDescriptor'
cap
                        TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest (TVar PromiseState -> PromiseState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
tvar) Client
client
                    R.Resolve'exception Exception
exn ->
                        TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest (TVar PromiseState -> PromiseState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
tvar) Exception
exn
                    R.Resolve'unknown' Word16
tag ->
                        Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eUnimplemented (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                            [ Text
"Resolve variant #"
                            , String -> Text
forall a. IsString a => String -> a
fromString (Word16 -> String
forall a. Show a => a -> String
show Word16
tag)
                            , Text
" not understood"
                            ]

handleReleaseMsg :: Conn -> R.Release -> STM ()
handleReleaseMsg :: Conn -> Release -> STM ()
handleReleaseMsg
        Conn
conn
        R.Release
            { $sel:id:Release :: Release -> Word32
id=(Word32 -> IEId
IEId -> IEId
eid)
            , $sel:referenceCount:Release :: Release -> Word32
referenceCount=Word32
refCountDiff
            } =
    Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Word32
refCountDiff IEId
eid

releaseExport :: Conn -> Word32 -> IEId -> STM ()
releaseExport :: Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Word32
refCountDiff IEId
eid =
    Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \conn' :: Conn'
conn'@Conn'{Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports} ->
        Text
-> Conn' -> Map IEId EntryE -> IEId -> (EntryE -> STM ()) -> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
"export" Conn'
conn' Map IEId EntryE
exports IEId
eid ((EntryE -> STM ()) -> STM ()) -> (EntryE -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$
            \EntryE{Client'
client :: Client'
$sel:client:EntryE :: EntryE -> Client'
client, $sel:refCount:EntryE :: EntryE -> Word32
refCount=Word32
oldRefCount} ->
                case Word32 -> Word32 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word32
oldRefCount Word32
refCountDiff of
                    Ordering
LT ->
                        Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                            Text
"Received release for export with referenceCount " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Text
"greater than our recorded total ref count."
                    Ordering
EQ ->
                        Conn -> Client' -> STM ()
dropConnExport Conn
conn Client'
client
                    Ordering
GT ->
                        EntryE -> IEId -> Map IEId EntryE -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
                            EntryE :: Client' -> Word32 -> EntryE
EntryE
                                { Client'
client :: Client'
$sel:client:EntryE :: Client'
client
                                , $sel:refCount:EntryE :: Word32
refCount = Word32
oldRefCount Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
refCountDiff
                                }
                            IEId
eid
                            Map IEId EntryE
exports

handleDisembargoMsg :: Conn -> R.Disembargo -> STM ()
handleDisembargoMsg :: Conn -> Disembargo -> STM ()
handleDisembargoMsg Conn
conn Disembargo
d = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Disembargo -> Conn' -> STM ()
go Disembargo
d
  where
    go :: Disembargo -> Conn' -> STM ()
go
        R.Disembargo { $sel:context:Disembargo :: Disembargo -> Disembargo'context
context=R.Disembargo'context'receiverLoopback (Word32 -> EmbargoId
EmbargoId -> EmbargoId
eid) }
        conn' :: Conn'
conn'@Conn'{Map EmbargoId (Fulfiller ())
embargos :: Map EmbargoId (Fulfiller ())
$sel:embargos:Conn' :: Conn' -> Map EmbargoId (Fulfiller ())
embargos}
        = do
            Maybe (Fulfiller ())
result <- EmbargoId
-> Map EmbargoId (Fulfiller ()) -> STM (Maybe (Fulfiller ()))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup EmbargoId
eid Map EmbargoId (Fulfiller ())
embargos
            case Maybe (Fulfiller ())
result of
                Maybe (Fulfiller ())
Nothing ->
                    Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                        Text
"No such embargo: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word32 -> String
forall a. Show a => a -> String
show (Word32 -> String) -> Word32 -> String
forall a b. (a -> b) -> a -> b
$ EmbargoId -> Word32
embargoWord EmbargoId
eid)
                Just Fulfiller ()
fulfiller -> do
                    Conn' -> STM () -> STM ()
queueSTM Conn'
conn' (Fulfiller () -> () -> STM ()
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller ()
fulfiller ())
                    EmbargoId -> Map EmbargoId (Fulfiller ()) -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete EmbargoId
eid Map EmbargoId (Fulfiller ())
embargos
                    Conn' -> EmbargoId -> STM ()
freeEmbargo Conn'
conn' EmbargoId
eid
    go
        R.Disembargo{ MessageTarget
$sel:target:Disembargo :: Disembargo -> MessageTarget
target :: MessageTarget
target, $sel:context:Disembargo :: Disembargo -> Disembargo'context
context=R.Disembargo'context'senderLoopback Word32
embargoId }
        conn' :: Conn'
conn'@Conn'{Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports, Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers}
        = case MessageTarget
target of
            R.MessageTarget'importedCap Word32
exportId ->
                Text
-> Conn' -> Map IEId EntryE -> IEId -> (EntryE -> STM ()) -> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
"export" Conn'
conn' Map IEId EntryE
exports (Word32 -> IEId
IEId Word32
exportId) ((EntryE -> STM ()) -> STM ()) -> (EntryE -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \EntryE{ Client'
client :: Client'
$sel:client:EntryE :: EntryE -> Client'
client } ->
                    Client' -> STM ()
disembargoPromise Client'
client
            R.MessageTarget'promisedAnswer R.PromisedAnswer{ Word32
questionId :: Word32
$sel:questionId:PromisedAnswer :: PromisedAnswer -> Word32
questionId, Vector PromisedAnswer'Op
transform :: Vector PromisedAnswer'Op
$sel:transform:PromisedAnswer :: PromisedAnswer -> Vector PromisedAnswer'Op
transform } ->
                Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (EntryQA -> STM ())
-> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
"answer" Conn'
conn' Map QAId EntryQA
answers (Word32 -> QAId
QAId Word32
questionId) ((EntryQA -> STM ()) -> STM ()) -> (EntryQA -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
                    HaveReturn { $sel:returnMsg:NewQA :: EntryQA -> Return
returnMsg=Return{$sel:union':Return :: Return -> Return'
union'=Return'results Payload{RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content} } } ->
                        Vector PromisedAnswer'Op -> RawMPtr -> Conn' -> STM Client
transformClient Vector PromisedAnswer'Op
transform RawMPtr
content Conn'
conn' STM Client -> (Client -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                            Client (Just Client'
client') -> Client' -> STM ()
disembargoClient Client'
client'
                            Client Maybe Client'
Nothing -> Text -> STM ()
abortDisembargo Text
"targets a null capability"
                    EntryQA
_ ->
                        Text -> STM ()
abortDisembargo (Text -> STM ()) -> Text -> STM ()
forall a b. (a -> b) -> a -> b
$
                            Text
"does not target an answer which has resolved to a value hosted by"
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" the sender."
            R.MessageTarget'unknown' Word16
ordinal ->
                Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eUnimplemented (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                    Text
"Unknown MessageTarget ordinal #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word16 -> String
forall a. Show a => a -> String
show Word16
ordinal)
      where
        disembargoPromise :: Client' -> STM ()
disembargoPromise PromiseClient{ TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: Client' -> TVar PromiseState
pState } = TVar PromiseState -> STM PromiseState
forall a. TVar a -> STM a
readTVar TVar PromiseState
pState STM PromiseState -> (PromiseState -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Ready (Client (Just Client'
client)) ->
                Client' -> STM ()
disembargoClient Client'
client
            Ready (Client Maybe Client'
Nothing) ->
                Text -> STM ()
abortDisembargo Text
"targets a promise which resolved to null."
            PromiseState
_ ->
                Text -> STM ()
abortDisembargo Text
"targets a promise which has not resolved."
        disembargoPromise Client'
_ =
            Text -> STM ()
abortDisembargo Text
"targets something that is not a promise."

        disembargoClient :: Client' -> STM ()
disembargoClient (ImportClient Cell ImportRef
cell) = do
            ImportRef
client <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
            case ImportRef
client of
                ImportRef {$sel:conn:ImportRef :: ImportRef -> Conn
conn=Conn
targetConn, IEId
importId :: IEId
$sel:importId:ImportRef :: ImportRef -> IEId
importId}
                    | Conn
conn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
targetConn ->
                        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Disembargo -> Message
R.Message'disembargo Disembargo :: MessageTarget -> Disembargo'context -> Disembargo
R.Disembargo
                            { $sel:context:Disembargo :: Disembargo'context
context = Word32 -> Disembargo'context
R.Disembargo'context'receiverLoopback Word32
embargoId
                            , $sel:target:Disembargo :: MessageTarget
target = Word32 -> MessageTarget
R.MessageTarget'importedCap (IEId -> Word32
ieWord IEId
importId)
                            }
                ImportRef
_ ->
                    STM ()
abortDisembargoClient
        disembargoClient Client'
_ = STM ()
abortDisembargoClient

        abortDisembargoClient :: STM ()
abortDisembargoClient =
                Text -> STM ()
abortDisembargo (Text -> STM ()) -> Text -> STM ()
forall a b. (a -> b) -> a -> b
$
                    Text
"targets a promise which has not resolved to a capability"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" hosted by the sender."

        abortDisembargo :: Text -> STM ()
abortDisembargo Text
info =
            Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"Disembargo #"
                , String -> Text
forall a. IsString a => String -> a
fromString (Word32 -> String
forall a. Show a => a -> String
show Word32
embargoId)
                , Text
" with context = senderLoopback "
                , Text
info
                ]
-- Note [Level 3]
    go Disembargo
d Conn'
conn' =
        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Message -> Message
R.Message'unimplemented (Message -> Message) -> Message -> Message
forall a b. (a -> b) -> a -> b
$ Disembargo -> Message
R.Message'disembargo Disembargo
d

lookupAbort
    :: (Eq k, Hashable k, Show k)
    => Text -> Conn' -> M.Map k v -> k -> (v -> STM a) -> STM a
lookupAbort :: Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
keyTypeName Conn'
conn Map k v
m k
key v -> STM a
f = do
    Maybe v
result <- k -> Map k v -> STM (Maybe v)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup k
key Map k v
m
    case Maybe v
result of
        Just v
val ->
            v -> STM a
f v
val
        Maybe v
Nothing ->
            Conn' -> Exception -> STM a
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn (Exception -> STM a) -> Exception -> STM a
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"No such "
                , Text
keyTypeName
                ,  Text
": "
                , String -> Text
forall a. IsString a => String -> a
fromString (k -> String
forall a. Show a => a -> String
show k
key)
                ]

-- | @'insertNewAbort' keyTypeName conn key value stmMap@ inserts a key into a
-- map, aborting the connection if it is already present. @keyTypeName@ will be
-- used in the error message sent to the remote vat.
insertNewAbort :: (Eq k, Hashable k) => Text -> Conn' -> k -> v -> M.Map k v -> STM ()
insertNewAbort :: Text -> Conn' -> k -> v -> Map k v -> STM ()
insertNewAbort Text
keyTypeName Conn'
conn k
key v
value =
    Focus v STM () -> k -> Map k v -> STM ()
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
M.focus
        ((Maybe v -> STM (Maybe v)) -> Focus v STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> m (Maybe a)) -> Focus a m ()
Focus.alterM ((Maybe v -> STM (Maybe v)) -> Focus v STM ())
-> (Maybe v -> STM (Maybe v)) -> Focus v STM ()
forall a b. (a -> b) -> a -> b
$ \case
            Just v
_ ->
                Conn' -> Exception -> STM (Maybe v)
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn (Exception -> STM (Maybe v)) -> Exception -> STM (Maybe v)
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                    Text
"duplicate entry in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
keyTypeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" table."
            Maybe v
Nothing ->
                Maybe v -> STM (Maybe v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> Maybe v
forall a. a -> Maybe a
Just v
value)
        )
        k
key

-- | Generate a cap table describing the capabilities reachable from the given
-- pointer. The capability table will be correct for any message where all of
-- the capabilities are within the subtree under the pointer.
genSendableCapTableRaw
    :: Conn
    -> Maybe (UntypedRaw.Ptr 'Const)
    -> STM (V.Vector R.CapDescriptor)
genSendableCapTableRaw :: Conn -> RawMPtr -> STM (Vector CapDescriptor)
genSendableCapTableRaw Conn
_ RawMPtr
Nothing = Vector CapDescriptor -> STM (Vector CapDescriptor)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector CapDescriptor
forall a. Vector a
V.empty
genSendableCapTableRaw Conn
conn (Just Ptr 'Const
ptr) =
    (Client -> STM CapDescriptor)
-> Vector Client -> STM (Vector CapDescriptor)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
        (\Client
c -> do
            CapDescriptor'
union' <- Conn -> Client -> STM CapDescriptor'
emitCap Conn
conn Client
c
            CapDescriptor -> STM CapDescriptor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CapDescriptor
forall a. Default a => a
def :: R.CapDescriptor) { $sel:union':CapDescriptor :: CapDescriptor'
R.union' = CapDescriptor'
union' }
        )
        (Message 'Const -> Vector Client
Message.getCapTable (Ptr 'Const -> Message 'Const
forall a (mut :: Mutability). HasMessage a mut => a -> Message mut
UntypedRaw.message Ptr 'Const
ptr))

-- | Convert the pointer into a Payload, including a capability table for
-- the clients in the pointer's cap table.
makeOutgoingPayload :: Conn -> RawMPtr -> STM Payload
makeOutgoingPayload :: Conn -> RawMPtr -> STM Payload
makeOutgoingPayload Conn
conn RawMPtr
content = do
    Vector CapDescriptor
capTable <- Conn -> RawMPtr -> STM (Vector CapDescriptor)
genSendableCapTableRaw Conn
conn RawMPtr
content
    Payload -> STM Payload
forall (f :: * -> *) a. Applicative f => a -> f a
pure Payload :: RawMPtr -> Vector CapDescriptor -> Payload
Payload { RawMPtr
content :: RawMPtr
$sel:content:Payload :: RawMPtr
content, Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Vector CapDescriptor
capTable }

sendPureMsg :: Conn' -> R.Message -> STM ()
sendPureMsg :: Conn' -> Message -> STM ()
sendPureMsg Conn'{TBQueue (Message 'Const)
sendQ :: TBQueue (Message 'Const)
$sel:sendQ:Conn' :: Conn' -> TBQueue (Message 'Const)
sendQ} Message
msg =
    WordCount
-> (forall s. PureBuilder s (Mutable s (Message 'Const)))
-> STM (Message 'Const)
forall (m :: * -> *) a.
(MonadThrow m, Thaw a) =>
WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a
createPure WordCount
forall a. Bounded a => a
maxBound (Message -> PureBuilder s (Message ('Mut s))
forall (m :: * -> *) s a.
(MonadLimit m, WriteCtx m s, Cerialize s a,
 ToStruct ('Mut s) (Cerial ('Mut s) a)) =>
a -> m (Message ('Mut s))
valueToMsg Message
msg) STM (Message 'Const) -> (Message 'Const -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TBQueue (Message 'Const) -> Message 'Const -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Message 'Const)
sendQ

-- | Send a finish message, updating connection state and triggering
-- callbacks as necessary.
finishQuestion :: Conn' -> R.Finish -> STM ()
finishQuestion :: Conn' -> Finish -> STM ()
finishQuestion conn :: Conn'
conn@Conn'{Map QAId EntryQA
questions :: Map QAId EntryQA
$sel:questions:Conn' :: Conn' -> Map QAId EntryQA
questions} finish :: Finish
finish@R.Finish{Word32
questionId :: Word32
$sel:questionId:Finish :: Finish -> Word32
questionId} = do
    -- arrange for the question ID to be returned to the pool once
    -- the return has also been received:
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"question" Conn'
conn Map QAId EntryQA
questions (Word32 -> QAId
QAId Word32
questionId) ((Return -> STM ()) -> STM ()) -> (Return -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \Return
_ ->
        Conn' -> QAId -> STM ()
freeQuestion Conn'
conn (Word32 -> QAId
QAId Word32
questionId)
    Conn' -> Message -> STM ()
sendPureMsg Conn'
conn (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Finish -> Message
R.Message'finish Finish
finish
    Conn' -> Map QAId EntryQA -> Text -> Finish -> STM ()
updateQAFinish Conn'
conn Map QAId EntryQA
questions Text
"question" Finish
finish

-- | Send a return message, update the corresponding entry in our
-- answers table, and queue any registered callbacks. Calls 'error'
-- if the answerId is not in the table, or if we've already sent a
-- return for this answer.
returnAnswer :: Conn' -> Return -> STM ()
returnAnswer :: Conn' -> Return -> STM ()
returnAnswer conn :: Conn'
conn@Conn'{Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} Return
ret = do
    Conn' -> Return -> STM ()
sendReturn Conn'
conn Return
ret
    Conn' -> Map QAId EntryQA -> Text -> Return -> STM ()
updateQAReturn Conn'
conn Map QAId EntryQA
answers Text
"answer" Return
ret

-- TODO(cleanup): updateQAReturn/Finish have a lot in common; can we refactor?

updateQAReturn :: Conn' -> M.Map QAId EntryQA -> Text -> Return -> STM ()
updateQAReturn :: Conn' -> Map QAId EntryQA -> Text -> Return -> STM ()
updateQAReturn Conn'
conn Map QAId EntryQA
table Text
tableName ret :: Return
ret@Return{QAId
answerId :: QAId
$sel:answerId:Return :: Return -> QAId
answerId} =
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (EntryQA -> STM ())
-> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
tableName Conn'
conn Map QAId EntryQA
table QAId
answerId ((EntryQA -> STM ()) -> STM ()) -> (EntryQA -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
        NewQA{SnocList (Finish -> STM ())
onFinish :: SnocList (Finish -> STM ())
$sel:onFinish:NewQA :: EntryQA -> SnocList (Finish -> STM ())
onFinish, SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} -> do
            EntryQA -> QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
                HaveReturn :: Return -> SnocList (Finish -> STM ()) -> EntryQA
HaveReturn
                    { $sel:returnMsg:NewQA :: Return
returnMsg = Return
ret
                    , SnocList (Finish -> STM ())
onFinish :: SnocList (Finish -> STM ())
$sel:onFinish:NewQA :: SnocList (Finish -> STM ())
onFinish
                    }
                QAId
answerId
                Map QAId EntryQA
table
            ((Return -> STM ()) -> STM ())
-> SnocList (Return -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Return -> STM ()) -> Return -> STM ()
forall a b. (a -> b) -> a -> b
$ Return
ret) SnocList (Return -> STM ())
onReturn
        HaveFinish{SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} -> do
            QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete QAId
answerId Map QAId EntryQA
table
            ((Return -> STM ()) -> STM ())
-> SnocList (Return -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Return -> STM ()) -> Return -> STM ()
forall a b. (a -> b) -> a -> b
$ Return
ret) SnocList (Return -> STM ())
onReturn
        HaveReturn{} ->
            Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                Text
"Duplicate return message for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (QAId -> String
forall a. Show a => a -> String
show QAId
answerId)

updateQAFinish :: Conn' -> M.Map QAId EntryQA -> Text -> R.Finish -> STM ()
updateQAFinish :: Conn' -> Map QAId EntryQA -> Text -> Finish -> STM ()
updateQAFinish Conn'
conn Map QAId EntryQA
table Text
tableName finish :: Finish
finish@R.Finish{Word32
questionId :: Word32
$sel:questionId:Finish :: Finish -> Word32
questionId} =
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (EntryQA -> STM ())
-> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
tableName Conn'
conn Map QAId EntryQA
table (Word32 -> QAId
QAId Word32
questionId) ((EntryQA -> STM ()) -> STM ()) -> (EntryQA -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
        NewQA{SnocList (Finish -> STM ())
onFinish :: SnocList (Finish -> STM ())
$sel:onFinish:NewQA :: EntryQA -> SnocList (Finish -> STM ())
onFinish, SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} -> do
            ((Finish -> STM ()) -> STM ())
-> SnocList (Finish -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Finish -> STM ()) -> Finish -> STM ()
forall a b. (a -> b) -> a -> b
$ Finish
finish) SnocList (Finish -> STM ())
onFinish
            EntryQA -> QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
                HaveFinish :: Finish -> SnocList (Return -> STM ()) -> EntryQA
HaveFinish
                    { $sel:finishMsg:NewQA :: Finish
finishMsg = Finish
finish
                    , SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn
                    }
                (Word32 -> QAId
QAId Word32
questionId)
                Map QAId EntryQA
table
        HaveReturn{SnocList (Finish -> STM ())
onFinish :: SnocList (Finish -> STM ())
$sel:onFinish:NewQA :: EntryQA -> SnocList (Finish -> STM ())
onFinish} -> do
            ((Finish -> STM ()) -> STM ())
-> SnocList (Finish -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Finish -> STM ()) -> Finish -> STM ()
forall a b. (a -> b) -> a -> b
$ Finish
finish) SnocList (Finish -> STM ())
onFinish
            QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete (Word32 -> QAId
QAId Word32
questionId) Map QAId EntryQA
table
        HaveFinish{} ->
            Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                Text
"Duplicate finish message for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word32 -> String
forall a. Show a => a -> String
show Word32
questionId)

-- | Update an entry in the questions or answers table to queue the given
-- callback when the return message for that answer comes in. If the return
-- has already arrived, the callback is queued immediately.
--
-- If the entry already has other callbacks registered, this callback is
-- run *after* the others (see Note [callbacks]). Note that this is an
-- important property, as it is necessary to preserve E-order if the
-- callbacks are successive method calls on the returned object.
subscribeReturn :: Text -> Conn' -> M.Map QAId EntryQA -> QAId -> (Return -> STM ()) -> STM ()
subscribeReturn :: Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
tableName Conn'
conn Map QAId EntryQA
table QAId
qaId Return -> STM ()
onRet =
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (EntryQA -> STM ())
-> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
tableName Conn'
conn Map QAId EntryQA
table QAId
qaId ((EntryQA -> STM ()) -> STM ()) -> (EntryQA -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \EntryQA
qa -> do
        EntryQA
new <- EntryQA -> STM EntryQA
go EntryQA
qa
        EntryQA -> QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert EntryQA
new QAId
qaId Map QAId EntryQA
table
  where
    go :: EntryQA -> STM EntryQA
go = \case
        NewQA{SnocList (Finish -> STM ())
onFinish :: SnocList (Finish -> STM ())
$sel:onFinish:NewQA :: EntryQA -> SnocList (Finish -> STM ())
onFinish, SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} ->
            EntryQA -> STM EntryQA
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewQA :: SnocList (Finish -> STM ())
-> SnocList (Return -> STM ()) -> EntryQA
NewQA
                { SnocList (Finish -> STM ())
onFinish :: SnocList (Finish -> STM ())
$sel:onFinish:NewQA :: SnocList (Finish -> STM ())
onFinish
                , $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn = SnocList (Return -> STM ())
-> (Return -> STM ()) -> SnocList (Return -> STM ())
forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList (Return -> STM ())
onReturn Return -> STM ()
onRet
                }

        HaveFinish{Finish
finishMsg :: Finish
$sel:finishMsg:NewQA :: EntryQA -> Finish
finishMsg, SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} ->
            EntryQA -> STM EntryQA
forall (f :: * -> *) a. Applicative f => a -> f a
pure HaveFinish :: Finish -> SnocList (Return -> STM ()) -> EntryQA
HaveFinish
                { Finish
finishMsg :: Finish
$sel:finishMsg:NewQA :: Finish
finishMsg
                , $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn = SnocList (Return -> STM ())
-> (Return -> STM ()) -> SnocList (Return -> STM ())
forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList (Return -> STM ())
onReturn Return -> STM ()
onRet
                }

        val :: EntryQA
val@HaveReturn{Return
returnMsg :: Return
$sel:returnMsg:NewQA :: EntryQA -> Return
returnMsg} -> do
            Conn' -> STM () -> STM ()
queueSTM Conn'
conn (Return -> STM ()
onRet Return
returnMsg)
            EntryQA -> STM EntryQA
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryQA
val

-- | Abort the connection, sending an abort message. This is only safe to call
-- from within either the thread running the coordinator or the callback loop.
abortConn :: Conn' -> R.Exception -> STM a
abortConn :: Conn' -> Exception -> STM a
abortConn Conn'
_ Exception
e = RpcError -> STM a
forall e a. Exception e => e -> STM a
throwSTM (Exception -> RpcError
SentAbort Exception
e)

-- | Gets the live connection state, or throws disconnected if it is not live.
getLive :: Conn -> STM Conn'
getLive :: Conn -> STM Conn'
getLive Conn{TVar LiveState
liveState :: TVar LiveState
$sel:liveState:Conn :: Conn -> TVar LiveState
liveState} = TVar LiveState -> STM LiveState
forall a. TVar a -> STM a
readTVar TVar LiveState
liveState STM LiveState -> (LiveState -> STM Conn') -> STM Conn'
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Live Conn'
conn' -> Conn' -> STM Conn'
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conn'
conn'
    LiveState
Dead       -> Exception -> STM Conn'
forall e a. Exception e => e -> STM a
throwSTM Exception
eDisconnected

-- | Performs an action with the live connection state. Does nothing if the
-- connection is dead.
whenLive :: Conn -> (Conn' -> STM ()) -> STM ()
whenLive :: Conn -> (Conn' -> STM ()) -> STM ()
whenLive Conn{TVar LiveState
liveState :: TVar LiveState
$sel:liveState:Conn :: Conn -> TVar LiveState
liveState} Conn' -> STM ()
f = TVar LiveState -> STM LiveState
forall a. TVar a -> STM a
readTVar TVar LiveState
liveState STM LiveState -> (LiveState -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Live Conn'
conn' -> Conn' -> STM ()
f Conn'
conn'
    LiveState
Dead       -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Request the remote vat's bootstrap interface.
requestBootstrap :: Conn -> STM Client
requestBootstrap :: Conn -> STM Client
requestBootstrap conn :: Conn
conn@Conn{TVar LiveState
liveState :: TVar LiveState
$sel:liveState:Conn :: Conn -> TVar LiveState
liveState} = TVar LiveState -> STM LiveState
forall a. TVar a -> STM a
readTVar TVar LiveState
liveState STM LiveState -> (LiveState -> STM Client) -> STM Client
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LiveState
Dead ->
        Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
nullClient
    Live conn' :: Conn'
conn'@Conn'{Map QAId EntryQA
questions :: Map QAId EntryQA
$sel:questions:Conn' :: Conn' -> Map QAId EntryQA
questions} -> do
        QAId
qid <- Conn' -> STM QAId
newQuestion Conn'
conn'
        let tmpDest :: TmpDest
tmpDest = RemoteDest -> TmpDest
RemoteDest AnswerDest :: Conn -> PromisedAnswer -> RemoteDest
AnswerDest
                { Conn
conn :: Conn
$sel:conn:AnswerDest :: Conn
conn
                , $sel:answer:AnswerDest :: PromisedAnswer
answer = PromisedAnswer :: QAId -> SnocList Word16 -> PromisedAnswer
PromisedAnswer
                    { $sel:answerId:PromisedAnswer :: QAId
answerId = QAId
qid
                    , $sel:transform:PromisedAnswer :: SnocList Word16
transform = SnocList Word16
forall a. SnocList a
SnocList.empty
                    }
                }
        TVar PromiseState
pState <- PromiseState -> STM (TVar PromiseState)
forall a. a -> STM (TVar a)
newTVar Pending :: TmpDest -> PromiseState
Pending { TmpDest
tmpDest :: TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest }
        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$
            Bootstrap -> Message
R.Message'bootstrap Bootstrap
forall a. Default a => a
def { $sel:questionId:Bootstrap :: Word32
R.questionId = QAId -> Word32
qaWord QAId
qid }
        EntryQA -> QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
            NewQA :: SnocList (Finish -> STM ())
-> SnocList (Return -> STM ()) -> EntryQA
NewQA
                { $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn = [Return -> STM ()] -> SnocList (Return -> STM ())
forall a. [a] -> SnocList a
SnocList.fromList
                    [ TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest (TVar PromiseState -> PromiseState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) Conn'
conn' []
                    , \Return
_ -> Conn' -> Finish -> STM ()
finishQuestion Conn'
conn' Finish :: Word32 -> Bool -> Finish
R.Finish
                        { $sel:questionId:Finish :: Word32
questionId = QAId -> Word32
qaWord QAId
qid
                        , $sel:releaseResultCaps:Finish :: Bool
releaseResultCaps = Bool
False
                        }
                    ]
                , $sel:onFinish:NewQA :: SnocList (Finish -> STM ())
onFinish = SnocList (Finish -> STM ())
forall a. SnocList a
SnocList.empty
                }
            QAId
qid
            Map QAId EntryQA
questions
        ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap (Map Conn IEId -> ExportMap)
-> STM (Map Conn IEId) -> STM ExportMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map Conn IEId)
forall key value. STM (Map key value)
M.new
        Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> STM Client) -> Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just PromiseClient :: TVar PromiseState -> ExportMap -> TmpDest -> Client'
PromiseClient
            { TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: TVar PromiseState
pState
            , ExportMap
exportMap :: ExportMap
$sel:exportMap:LocalClient :: ExportMap
exportMap
            , $sel:origTarget:LocalClient :: TmpDest
origTarget = TmpDest
tmpDest
            }

-- Note [resolveClient]
-- ====================
--
-- There are several functions resolveClient*, each of which resolves a
-- 'PromiseClient', which will previously have been in the 'Pending' state.
-- Each function accepts three parameters: the 'TmpDest' that the
-- pending promise had been targeting, a function for setting the new state,
-- and a thing to resolve the promise to. The type of the latter is specific
-- to each function.

-- | Resolve a promised client to an exception. See Note [resolveClient]
resolveClientExn :: TmpDest -> (PromiseState -> STM ()) -> R.Exception -> STM ()
resolveClientExn :: TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Exception
exn = do
    case TmpDest
tmpDest of
        LocalDest LocalBuffer { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: LocalDest -> TQueue CallInfo
callBuffer } -> do
            [CallInfo]
calls <- TQueue CallInfo -> STM [CallInfo]
forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer
            (CallInfo -> STM ()) -> [CallInfo] -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
                (\Server.CallInfo{Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response} ->
                    Fulfiller RawMPtr -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller RawMPtr
response Exception
exn)
                [CallInfo]
calls
        RemoteDest AnswerDest {} ->
            () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        RemoteDest (ImportDest Cell ImportRef
_) ->
            () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PromiseState -> STM ()
resolve (PromiseState -> STM ()) -> PromiseState -> STM ()
forall a b. (a -> b) -> a -> b
$ Exception -> PromiseState
Error Exception
exn

-- Resolve a promised client to a pointer. If it is a non-null non-capability
-- pointer, it resolves to an exception. See Note [resolveClient]
resolveClientPtr :: TmpDest -> (PromiseState -> STM ()) -> RawMPtr -> STM ()
resolveClientPtr :: TmpDest -> (PromiseState -> STM ()) -> RawMPtr -> STM ()
resolveClientPtr TmpDest
tmpDest PromiseState -> STM ()
resolve RawMPtr
ptr = case RawMPtr
ptr of
    RawMPtr
Nothing ->
        TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest PromiseState -> STM ()
resolve Client
nullClient
    Just (UntypedRaw.PtrCap Cap 'Const
c) -> do
        Client
c' <- WordCount -> LimitT STM Client -> STM Client
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT STM Client -> STM Client)
-> LimitT STM Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Cap 'Const -> LimitT STM Client
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
UntypedRaw.getClient Cap 'Const
c
        TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest PromiseState -> STM ()
resolve Client
c'
    Just Ptr 'Const
_ ->
        TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$
            Text -> Exception
eFailed Text
"Promise resolved to non-capability pointer"

-- | Resolve a promised client to another client. See Note [resolveClient]
resolveClientClient :: TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient :: TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest PromiseState -> STM ()
resolve (Client Maybe Client'
client) =
    case (Maybe Client'
client, TmpDest
tmpDest) of
        -- Remote resolved to local; we need to embargo:
        ( Just LocalClient{}, RemoteDest RemoteDest
dest ) ->
            RemoteDest -> STM ()
disembargoAndResolve RemoteDest
dest
        ( Just PromiseClient { $sel:origTarget:LocalClient :: Client' -> TmpDest
origTarget=LocalDest LocalDest
_ }, RemoteDest RemoteDest
dest) ->
            RemoteDest -> STM ()
disembargoAndResolve RemoteDest
dest
        ( Maybe Client'
Nothing, RemoteDest RemoteDest
dest ) ->
            -- It's not clear to me what we should actually do if the promise
            -- resolves to nullClient, but this can be encoded at the protocol
            -- level, so we have to deal with it. Possible options:
            --
            -- 1. Perhaps this is simply illegal, and we should send an abort?
            -- 2. Treat it as resolving to a local promise, in which case we
            --    need to send a disembargo as above.
            -- 3. Treat is as resolving to a remote promise, in which case we
            --    can't send an embargo.
            --
            -- (3) doesn't seem possible to implement quite correctly, since
            -- if we just resolve to nullClient right away, further calls will
            -- start returning exceptions before outstanding calls return -- we
            -- really do want to send a disembargo, but we can't because the
            -- protocol insists that we don't if the promise resolves to a
            -- remote cap.
            --
            -- What we currently do is (2); I(zenhack) intend to ask for
            -- clarification on the mailing list.
            RemoteDest -> STM ()
disembargoAndResolve RemoteDest
dest

        -- Local promises never need embargos; we can just forward:
        ( Maybe Client'
_, LocalDest LocalBuffer { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: LocalDest -> TQueue CallInfo
callBuffer } ) ->
            TQueue CallInfo -> STM ()
flushAndResolve TQueue CallInfo
callBuffer

        -- These cases are slightly subtle; despite resolving to a
        -- client that points at a "remote" target, if it points into a
        -- _different_ connection, we must be proxying it, so we treat
        -- it as local and do a disembargo like above. We may need to
        -- change this when we implement level 3, since third-party
        -- handoff is a possibility; see Note [Level 3].
        --
        -- If it's pointing into the same connection, we don't need to
        -- do a disembargo.
        ( Just PromiseClient { $sel:origTarget:LocalClient :: Client' -> TmpDest
origTarget=RemoteDest RemoteDest
newDest }, RemoteDest RemoteDest
oldDest ) -> do
            Conn
newConn <- RemoteDest -> STM Conn
destConn RemoteDest
newDest
            Conn
oldConn <- RemoteDest -> STM Conn
destConn RemoteDest
oldDest
            if Conn
newConn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
oldConn
                then STM ()
resolveNow
                else RemoteDest -> STM ()
disembargoAndResolve RemoteDest
oldDest
        ( Just (ImportClient Cell ImportRef
cell), RemoteDest RemoteDest
oldDest ) -> do
            ImportRef { $sel:conn:ImportRef :: ImportRef -> Conn
conn=Conn
newConn } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
            Conn
oldConn <- RemoteDest -> STM Conn
destConn RemoteDest
oldDest
            if Conn
newConn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
oldConn
                then STM ()
resolveNow
                else RemoteDest -> STM ()
disembargoAndResolve RemoteDest
oldDest
  where
    destConn :: RemoteDest -> STM Conn
destConn AnswerDest { Conn
conn :: Conn
$sel:conn:AnswerDest :: RemoteDest -> Conn
conn } = Conn -> STM Conn
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conn
conn
    destConn (ImportDest Cell ImportRef
cell) = do
        ImportRef { Conn
conn :: Conn
$sel:conn:ImportRef :: ImportRef -> Conn
conn } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
        Conn -> STM Conn
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conn
conn
    destTarget :: RemoteDest -> STM MsgTarget
destTarget AnswerDest { PromisedAnswer
answer :: PromisedAnswer
$sel:answer:AnswerDest :: RemoteDest -> PromisedAnswer
answer } = MsgTarget -> STM MsgTarget
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgTarget -> STM MsgTarget) -> MsgTarget -> STM MsgTarget
forall a b. (a -> b) -> a -> b
$ PromisedAnswer -> MsgTarget
AnswerTgt PromisedAnswer
answer
    destTarget (ImportDest Cell ImportRef
cell) = do
        ImportRef { IEId
importId :: IEId
$sel:importId:ImportRef :: ImportRef -> IEId
importId } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
        MsgTarget -> STM MsgTarget
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgTarget -> STM MsgTarget) -> MsgTarget -> STM MsgTarget
forall a b. (a -> b) -> a -> b
$ IEId -> MsgTarget
ImportTgt IEId
importId

    resolveNow :: STM ()
resolveNow = do
        PromiseState -> STM ()
resolve (PromiseState -> STM ()) -> PromiseState -> STM ()
forall a b. (a -> b) -> a -> b
$ Client -> PromiseState
Ready (Maybe Client' -> Client
Client Maybe Client'
client)

    -- Flush the call buffer into the client's queue, and then pass the client
    -- to resolve.
    flushAndResolve :: TQueue CallInfo -> STM ()
flushAndResolve TQueue CallInfo
callBuffer = do
        TQueue CallInfo -> STM [CallInfo]
forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer STM [CallInfo] -> ([CallInfo] -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CallInfo -> STM Pipeline) -> [CallInfo] -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (CallInfo -> Client -> STM Pipeline
forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m Pipeline
`call` Maybe Client' -> Client
Client Maybe Client'
client)
        PromiseState -> STM ()
resolve (PromiseState -> STM ()) -> PromiseState -> STM ()
forall a b. (a -> b) -> a -> b
$ Client -> PromiseState
Ready (Maybe Client' -> Client
Client Maybe Client'
client)
    flushAndRaise :: TQueue CallInfo -> Exception -> STM ()
flushAndRaise TQueue CallInfo
callBuffer Exception
e =
        TQueue CallInfo -> STM [CallInfo]
forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer STM [CallInfo] -> ([CallInfo] -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            (CallInfo -> STM ()) -> [CallInfo] -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Server.CallInfo{Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response} -> Fulfiller RawMPtr -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller RawMPtr
response Exception
e)
    disembargoAndResolve :: RemoteDest -> STM ()
disembargoAndResolve RemoteDest
dest = do
        Conn{TVar LiveState
liveState :: TVar LiveState
$sel:liveState:Conn :: Conn -> TVar LiveState
liveState} <- RemoteDest -> STM Conn
destConn RemoteDest
dest
        TVar LiveState -> STM LiveState
forall a. TVar a -> STM a
readTVar TVar LiveState
liveState STM LiveState -> (LiveState -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Live Conn'
conn' -> do
                TQueue CallInfo
callBuffer <- STM (TQueue CallInfo)
forall a. STM (TQueue a)
newTQueue
                MsgTarget
target <- RemoteDest -> STM MsgTarget
destTarget RemoteDest
dest
                Conn' -> MsgTarget -> (Either Exception () -> STM ()) -> STM ()
disembargo Conn'
conn' MsgTarget
target ((Either Exception () -> STM ()) -> STM ())
-> (Either Exception () -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
                    Right () ->
                        TQueue CallInfo -> STM ()
flushAndResolve TQueue CallInfo
callBuffer
                    Left Exception
e ->
                        TQueue CallInfo -> Exception -> STM ()
flushAndRaise TQueue CallInfo
callBuffer Exception
e
                PromiseState -> STM ()
resolve (PromiseState -> STM ()) -> PromiseState -> STM ()
forall a b. (a -> b) -> a -> b
$ Embargo :: TQueue CallInfo -> PromiseState
Embargo { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:Ready :: TQueue CallInfo
callBuffer }
            LiveState
Dead ->
                TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Exception
eDisconnected

-- | Send a (senderLoopback) disembargo to the given message target, and
-- register the transaction to run when the corresponding receiverLoopback
-- message is received.
--
-- The callback may be handed a 'Left' with a disconnected exception if
-- the connection is dropped before the disembargo is echoed.
disembargo :: Conn' -> MsgTarget -> (Either R.Exception () -> STM ()) -> STM ()
disembargo :: Conn' -> MsgTarget -> (Either Exception () -> STM ()) -> STM ()
disembargo conn :: Conn'
conn@Conn'{Map EmbargoId (Fulfiller ())
embargos :: Map EmbargoId (Fulfiller ())
$sel:embargos:Conn' :: Conn' -> Map EmbargoId (Fulfiller ())
embargos} MsgTarget
tgt Either Exception () -> STM ()
onEcho = do
    Fulfiller ()
callback <- (Either Exception () -> STM ()) -> STM (Fulfiller ())
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback Either Exception () -> STM ()
onEcho
    EmbargoId
eid <- Conn' -> STM EmbargoId
newEmbargo Conn'
conn
    Fulfiller () -> EmbargoId -> Map EmbargoId (Fulfiller ()) -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert Fulfiller ()
callback EmbargoId
eid Map EmbargoId (Fulfiller ())
embargos
    Conn' -> Message -> STM ()
sendPureMsg Conn'
conn (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Disembargo -> Message
R.Message'disembargo Disembargo :: MessageTarget -> Disembargo'context -> Disembargo
R.Disembargo
        { $sel:target:Disembargo :: MessageTarget
target = MsgTarget -> MessageTarget
marshalMsgTarget MsgTarget
tgt
        , $sel:context:Disembargo :: Disembargo'context
context = Word32 -> Disembargo'context
R.Disembargo'context'senderLoopback (EmbargoId -> Word32
embargoWord EmbargoId
eid)
        }

-- | Resolve a promised client to the result of a return. See Note [resolveClient]
--
-- The [Word16] is a list of pointer indexes to follow from the result.
resolveClientReturn :: TmpDest -> (PromiseState -> STM ()) -> Conn' -> [Word16] -> Return -> STM ()
resolveClientReturn :: TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest PromiseState -> STM ()
resolve conn :: Conn'
conn@Conn'{Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} [Word16]
transform Return { Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union' } = case Return'
union' of
    -- TODO(cleanup) there is a lot of redundency betwen this and cbCallReturn; can
    -- we refactor?
    Return'exception Exception
exn ->
        TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Exception
exn
    Return'results Payload{ RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content } -> do
        Either Exception RawMPtr
res <- STM RawMPtr -> STM (Either Exception RawMPtr)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (STM RawMPtr -> STM (Either Exception RawMPtr))
-> STM RawMPtr -> STM (Either Exception RawMPtr)
forall a b. (a -> b) -> a -> b
$ WordCount -> LimitT STM RawMPtr -> STM RawMPtr
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT STM RawMPtr -> STM RawMPtr)
-> LimitT STM RawMPtr -> STM RawMPtr
forall a b. (a -> b) -> a -> b
$ [Word16] -> RawMPtr -> LimitT STM RawMPtr
forall (m :: * -> *).
ReadCtx m 'Const =>
[Word16] -> RawMPtr -> m RawMPtr
followPtrs [Word16]
transform RawMPtr
content
        case Either Exception RawMPtr
res of
            Right RawMPtr
v ->
                TmpDest -> (PromiseState -> STM ()) -> RawMPtr -> STM ()
resolveClientPtr TmpDest
tmpDest PromiseState -> STM ()
resolve RawMPtr
v
            Left Exception
e ->
                TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Exception
e

    Return'
Return'canceled ->
        TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed Text
"Canceled"

    Return'
Return'resultsSentElsewhere ->
        -- Should never happen; we don't set sendResultsTo to anything other than
        -- caller.
        Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Received Return.resultsSentElsewhere for a call "
            , Text
"with sendResultsTo = caller."
            ]

    Return'takeFromOtherQuestion QAId
qid ->
        Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"answer" Conn'
conn Map QAId EntryQA
answers QAId
qid ((Return -> STM ()) -> STM ()) -> (Return -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$
            TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest PromiseState -> STM ()
resolve Conn'
conn [Word16]
transform

    Return'acceptFromThirdParty RawMPtr
_ ->
        -- Note [Level 3]
        Conn' -> Exception -> STM ()
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eUnimplemented
            Text
"This vat does not support level 3."

-- | Get the client's export ID for this connection, or allocate a new one if needed.
-- If this is the first time this client has been exported on this connection,
-- bump the refcount.
getConnExport :: Conn -> Client' -> STM IEId
getConnExport :: Conn -> Client' -> STM IEId
getConnExport Conn
conn Client'
client = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM IEId) -> STM IEId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \conn' :: Conn'
conn'@Conn'{Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports} -> do
    ExportMap Map Conn IEId
m <- Client' -> STM ExportMap
clientExportMap Client'
client
    Maybe IEId
val <- Conn -> Map Conn IEId -> STM (Maybe IEId)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup Conn
conn Map Conn IEId
m
    case Maybe IEId
val of
        Just IEId
eid -> do
            IEId -> Client' -> Map IEId EntryE -> STM ()
addBumpExport IEId
eid Client'
client Map IEId EntryE
exports
            IEId -> STM IEId
forall (f :: * -> *) a. Applicative f => a -> f a
pure IEId
eid

        Maybe IEId
Nothing -> do
            IEId
eid <- Conn' -> STM IEId
newExport Conn'
conn'
            IEId -> Client' -> Map IEId EntryE -> STM ()
addBumpExport IEId
eid Client'
client Map IEId EntryE
exports
            IEId -> Conn -> Map Conn IEId -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert IEId
eid Conn
conn Map Conn IEId
m
            IEId -> STM IEId
forall (f :: * -> *) a. Applicative f => a -> f a
pure IEId
eid

-- | Remove export of the client on the connection. This entails removing it
-- from the export id, removing the connection from the client's ExportMap,
-- freeing the export id, and dropping the client's refcount.
dropConnExport :: Conn -> Client' -> STM ()
dropConnExport :: Conn -> Client' -> STM ()
dropConnExport Conn
conn Client'
client' = do
    ExportMap Map Conn IEId
eMap <- Client' -> STM ExportMap
clientExportMap Client'
client'
    Maybe IEId
val <- Conn -> Map Conn IEId -> STM (Maybe IEId)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup Conn
conn Map Conn IEId
eMap
    case Maybe IEId
val of
        Just IEId
eid -> do
            Conn -> Map Conn IEId -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete Conn
conn Map Conn IEId
eMap
            Conn -> (Conn' -> STM ()) -> STM ()
whenLive Conn
conn ((Conn' -> STM ()) -> STM ()) -> (Conn' -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \conn' :: Conn'
conn'@Conn'{Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports} -> do
                IEId -> Map IEId EntryE -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete IEId
eid Map IEId EntryE
exports
                Conn' -> IEId -> STM ()
freeExport Conn'
conn' IEId
eid
        Maybe IEId
Nothing ->
            String -> STM ()
forall a. HasCallStack => String -> a
error String
"BUG: tried to drop an export that doesn't exist."

clientExportMap :: Client' -> STM ExportMap
clientExportMap :: Client' -> STM ExportMap
clientExportMap LocalClient{ExportMap
exportMap :: ExportMap
$sel:exportMap:LocalClient :: Client' -> ExportMap
exportMap}   = ExportMap -> STM ExportMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportMap
exportMap
clientExportMap PromiseClient{ExportMap
exportMap :: ExportMap
$sel:exportMap:LocalClient :: Client' -> ExportMap
exportMap} = ExportMap -> STM ExportMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportMap
exportMap
clientExportMap (ImportClient Cell ImportRef
cell) = do
    ImportRef{ExportMap
proxies :: ExportMap
$sel:proxies:ImportRef :: ImportRef -> ExportMap
proxies} <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
    ExportMap -> STM ExportMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportMap
proxies

-- | insert the client into the exports table, bumping the refcount if it is
-- already there. If a different client is already in the table at the same
-- id, call 'error'.
addBumpExport :: IEId -> Client' -> M.Map IEId EntryE -> STM ()
addBumpExport :: IEId -> Client' -> Map IEId EntryE -> STM ()
addBumpExport IEId
exportId Client'
client =
    Focus EntryE STM () -> IEId -> Map IEId EntryE -> STM ()
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
M.focus ((Maybe EntryE -> Maybe EntryE) -> Focus EntryE STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe EntryE -> Maybe EntryE
go) IEId
exportId
  where
    go :: Maybe EntryE -> Maybe EntryE
go Maybe EntryE
Nothing = EntryE -> Maybe EntryE
forall a. a -> Maybe a
Just EntryE :: Client' -> Word32 -> EntryE
EntryE { Client'
client :: Client'
$sel:client:EntryE :: Client'
client, $sel:refCount:EntryE :: Word32
refCount = Word32
1 }
    go (Just EntryE{ $sel:client:EntryE :: EntryE -> Client'
client = Client'
oldClient, Word32
refCount :: Word32
$sel:refCount:EntryE :: EntryE -> Word32
refCount } )
        | Client'
client Client' -> Client' -> Bool
forall a. Eq a => a -> a -> Bool
/= Client'
oldClient =
            String -> Maybe EntryE
forall a. HasCallStack => String -> a
error (String -> Maybe EntryE) -> String -> Maybe EntryE
forall a b. (a -> b) -> a -> b
$
                String
"BUG: addExportRef called with a client that is different " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                String
"from what is already in our exports table."
        | Bool
otherwise =
            EntryE -> Maybe EntryE
forall a. a -> Maybe a
Just EntryE :: Client' -> Word32 -> EntryE
EntryE { Client'
client :: Client'
$sel:client:EntryE :: Client'
client, $sel:refCount:EntryE :: Word32
refCount = Word32
refCount Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 }

-- | Generate a CapDescriptor', which we can send to the connection's remote
-- vat to identify client. In the process, this may allocate export ids, update
-- reference counts, and so forth.
emitCap :: Conn -> Client -> STM R.CapDescriptor'
emitCap :: Conn -> Client -> STM CapDescriptor'
emitCap Conn
_targetConn (Client Maybe Client'
Nothing) =
    CapDescriptor' -> STM CapDescriptor'
forall (f :: * -> *) a. Applicative f => a -> f a
pure CapDescriptor'
R.CapDescriptor'none
emitCap Conn
targetConn (Client (Just Client'
client')) = case Client'
client' of
    LocalClient{} ->
        Word32 -> CapDescriptor'
R.CapDescriptor'senderHosted (Word32 -> CapDescriptor')
-> (IEId -> Word32) -> IEId -> CapDescriptor'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEId -> Word32
ieWord (IEId -> CapDescriptor') -> STM IEId -> STM CapDescriptor'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conn -> Client' -> STM IEId
getConnExport Conn
targetConn Client'
client'
    PromiseClient{ TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: Client' -> TVar PromiseState
pState } -> TVar PromiseState -> STM PromiseState
forall a. TVar a -> STM a
readTVar TVar PromiseState
pState STM PromiseState
-> (PromiseState -> STM CapDescriptor') -> STM CapDescriptor'
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Pending { $sel:tmpDest:Ready :: PromiseState -> TmpDest
tmpDest = RemoteDest AnswerDest { Conn
conn :: Conn
$sel:conn:AnswerDest :: RemoteDest -> Conn
conn, PromisedAnswer
answer :: PromisedAnswer
$sel:answer:AnswerDest :: RemoteDest -> PromisedAnswer
answer } }
            | Conn
conn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
targetConn ->
                CapDescriptor' -> STM CapDescriptor'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CapDescriptor' -> STM CapDescriptor')
-> CapDescriptor' -> STM CapDescriptor'
forall a b. (a -> b) -> a -> b
$ PromisedAnswer -> CapDescriptor'
R.CapDescriptor'receiverAnswer (PromisedAnswer -> PromisedAnswer
marshalPromisedAnswer PromisedAnswer
answer)
        Pending { $sel:tmpDest:Ready :: PromiseState -> TmpDest
tmpDest = RemoteDest (ImportDest Cell ImportRef
cell) } -> do
            ImportRef { Conn
conn :: Conn
$sel:conn:ImportRef :: ImportRef -> Conn
conn, $sel:importId:ImportRef :: ImportRef -> IEId
importId = IEId Word32
iid } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
            if Conn
conn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
targetConn
                then CapDescriptor' -> STM CapDescriptor'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> CapDescriptor'
R.CapDescriptor'receiverHosted Word32
iid)
                else STM CapDescriptor'
newSenderPromise
        PromiseState
_ ->
            STM CapDescriptor'
newSenderPromise
    ImportClient Cell ImportRef
cell -> do
        ImportRef { $sel:conn:ImportRef :: ImportRef -> Conn
conn=Conn
hostConn, IEId
importId :: IEId
$sel:importId:ImportRef :: ImportRef -> IEId
importId } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
        if Conn
hostConn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
targetConn
            then CapDescriptor' -> STM CapDescriptor'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> CapDescriptor'
R.CapDescriptor'receiverHosted (IEId -> Word32
ieWord IEId
importId))
            else Word32 -> CapDescriptor'
R.CapDescriptor'senderHosted (Word32 -> CapDescriptor')
-> (IEId -> Word32) -> IEId -> CapDescriptor'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEId -> Word32
ieWord (IEId -> CapDescriptor') -> STM IEId -> STM CapDescriptor'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conn -> Client' -> STM IEId
getConnExport Conn
targetConn Client'
client'
  where
    newSenderPromise :: STM CapDescriptor'
newSenderPromise = Word32 -> CapDescriptor'
R.CapDescriptor'senderPromise (Word32 -> CapDescriptor')
-> (IEId -> Word32) -> IEId -> CapDescriptor'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEId -> Word32
ieWord (IEId -> CapDescriptor') -> STM IEId -> STM CapDescriptor'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conn -> Client' -> STM IEId
getConnExport Conn
targetConn Client'
client'

acceptPayload :: Conn -> RawRpc.Payload 'Const -> LimitT STM Payload
acceptPayload :: Conn -> Payload 'Const -> LimitT STM Payload
acceptPayload Conn
conn Payload 'Const
payload = do
    Vector CapDescriptor
capTable <- Payload 'Const -> LimitT STM (List 'Const (CapDescriptor 'Const))
forall (m :: * -> *) (msg :: Mutability).
(ReadCtx m msg, FromPtr msg (List msg (CapDescriptor msg))) =>
Payload msg -> m (List msg (CapDescriptor msg))
RawRpc.get_Payload'capTable Payload 'Const
payload LimitT STM (List 'Const (CapDescriptor 'Const))
-> (List 'Const (CapDescriptor 'Const)
    -> LimitT STM (Vector CapDescriptor))
-> LimitT STM (Vector CapDescriptor)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= List 'Const (CapDescriptor 'Const)
-> LimitT STM (Vector CapDescriptor)
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize
    Vector Client
clients <- STM (Vector Client) -> LimitT STM (Vector Client)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM (Vector Client) -> LimitT STM (Vector Client))
-> STM (Vector Client) -> LimitT STM (Vector Client)
forall a b. (a -> b) -> a -> b
$ (CapDescriptor -> STM Client)
-> Vector CapDescriptor -> STM (Vector Client)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\R.CapDescriptor{CapDescriptor'
union' :: CapDescriptor'
$sel:union':CapDescriptor :: CapDescriptor -> CapDescriptor'
union'} -> Conn -> CapDescriptor' -> STM Client
acceptCap Conn
conn CapDescriptor'
union') Vector CapDescriptor
capTable
    RawMPtr
content <- Payload 'Const -> LimitT STM RawMPtr
forall (m :: * -> *) (msg :: Mutability).
(ReadCtx m msg, FromPtr msg (Maybe (Ptr msg))) =>
Payload msg -> m (Maybe (Ptr msg))
RawRpc.get_Payload'content Payload 'Const
payload LimitT STM RawMPtr
-> (RawMPtr -> LimitT STM RawMPtr) -> LimitT STM RawMPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (Ptr 'Const -> LimitT STM (Ptr 'Const))
-> RawMPtr -> LimitT STM RawMPtr
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Message 'Const -> LimitT STM (Message 'Const))
-> Ptr 'Const -> LimitT STM (Ptr 'Const)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
UntypedRaw.tMsg (Message 'Const -> LimitT STM (Message 'Const)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message 'Const -> LimitT STM (Message 'Const))
-> (Message 'Const -> Message 'Const)
-> Message 'Const
-> LimitT STM (Message 'Const)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Client -> Message 'Const -> Message 'Const
Message.withCapTable Vector Client
clients))
    Payload -> LimitT STM Payload
forall (f :: * -> *) a. Applicative f => a -> f a
pure Payload :: RawMPtr -> Vector CapDescriptor -> Payload
Payload {RawMPtr
content :: RawMPtr
$sel:content:Payload :: RawMPtr
content, Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Vector CapDescriptor
capTable}

-- | 'acceptCap' is a dual of 'emitCap'; it derives a Client from a CapDescriptor'
-- received via the connection. May update connection state as necessary.
acceptCap :: Conn -> R.CapDescriptor' -> STM Client
acceptCap :: Conn -> CapDescriptor' -> STM Client
acceptCap Conn
conn CapDescriptor'
cap = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM Client) -> STM Client
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Conn'
conn' -> Conn' -> CapDescriptor' -> STM Client
go Conn'
conn' CapDescriptor'
cap
  where
    go :: Conn' -> CapDescriptor' -> STM Client
go Conn'
_ CapDescriptor'
R.CapDescriptor'none = Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Client' -> Client
Client Maybe Client'
forall a. Maybe a
Nothing)
    go conn' :: Conn'
conn'@Conn'{Map IEId EntryI
imports :: Map IEId EntryI
$sel:imports:Conn' :: Conn' -> Map IEId EntryI
imports} (R.CapDescriptor'senderHosted (Word32 -> IEId
IEId -> IEId
importId)) = do
        Maybe EntryI
entry <- IEId -> Map IEId EntryI -> STM (Maybe EntryI)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup IEId
importId Map IEId EntryI
imports
        case Maybe EntryI
entry of
            Just EntryI{ $sel:promiseState:EntryI :: EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState=Just (TVar PromiseState, TmpDest)
_ } ->
                let imp :: Text
imp = String -> Text
forall a. IsString a => String -> a
fromString (IEId -> String
forall a. Show a => a -> String
show IEId
importId)
                in Conn' -> Exception -> STM Client
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM Client) -> Exception -> STM Client
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                    Text
"received senderHosted capability #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
", but the imports table says #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is senderPromise."
            Just ent :: EntryI
ent@EntryI{ Rc ()
localRc :: Rc ()
$sel:localRc:EntryI :: EntryI -> Rc ()
localRc, Word32
remoteRc :: Word32
$sel:remoteRc:EntryI :: EntryI -> Word32
remoteRc, ExportMap
proxies :: ExportMap
$sel:proxies:EntryI :: EntryI -> ExportMap
proxies } -> do
                Rc () -> STM ()
forall a. Rc a -> STM ()
Rc.incr Rc ()
localRc
                EntryI -> IEId -> Map IEId EntryI -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert EntryI
ent { Rc ()
localRc :: Rc ()
$sel:localRc:EntryI :: Rc ()
localRc, $sel:remoteRc:EntryI :: Word32
remoteRc = Word32
remoteRc Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 } IEId
importId Map IEId EntryI
imports
                Cell ImportRef
cell <- ImportRef -> STM (Cell ImportRef)
forall (m :: * -> *) a. MonadSTM m => a -> m (Cell a)
Fin.newCell ImportRef :: Conn -> IEId -> ExportMap -> ImportRef
ImportRef
                    { Conn
conn :: Conn
$sel:conn:ImportRef :: Conn
conn
                    , IEId
importId :: IEId
$sel:importId:ImportRef :: IEId
importId
                    , ExportMap
proxies :: ExportMap
$sel:proxies:ImportRef :: ExportMap
proxies
                    }
                Conn' -> IO () -> STM ()
queueIO Conn'
conn' (IO () -> STM ()) -> IO () -> STM ()
forall a b. (a -> b) -> a -> b
$ Cell ImportRef -> IO () -> IO ()
forall a. Cell a -> IO () -> IO ()
Fin.addFinalizer Cell ImportRef
cell (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Rc () -> STM ()
forall a. Rc a -> STM ()
Rc.decr Rc ()
localRc
                Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> STM Client) -> Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just (Client' -> Maybe Client') -> Client' -> Maybe Client'
forall a b. (a -> b) -> a -> b
$ Cell ImportRef -> Client'
ImportClient Cell ImportRef
cell

            Maybe EntryI
Nothing ->
                Maybe Client' -> Client
Client (Maybe Client' -> Client)
-> (Cell ImportRef -> Maybe Client') -> Cell ImportRef -> Client
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client' -> Maybe Client'
forall a. a -> Maybe a
Just (Client' -> Maybe Client')
-> (Cell ImportRef -> Client') -> Cell ImportRef -> Maybe Client'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cell ImportRef -> Client'
ImportClient (Cell ImportRef -> Client) -> STM (Cell ImportRef) -> STM Client
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IEId
-> Conn
-> Maybe (TVar PromiseState, TmpDest)
-> STM (Cell ImportRef)
newImport IEId
importId Conn
conn Maybe (TVar PromiseState, TmpDest)
forall a. Maybe a
Nothing
    go conn' :: Conn'
conn'@Conn'{Map IEId EntryI
imports :: Map IEId EntryI
$sel:imports:Conn' :: Conn' -> Map IEId EntryI
imports} (R.CapDescriptor'senderPromise (Word32 -> IEId
IEId -> IEId
importId)) = do
        Maybe EntryI
entry <- IEId -> Map IEId EntryI -> STM (Maybe EntryI)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup IEId
importId Map IEId EntryI
imports
        case Maybe EntryI
entry of
            Just EntryI { $sel:promiseState:EntryI :: EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState=Maybe (TVar PromiseState, TmpDest)
Nothing } ->
                let imp :: Text
imp = String -> Text
forall a. IsString a => String -> a
fromString (IEId -> String
forall a. Show a => a -> String
show IEId
importId)
                in Conn' -> Exception -> STM Client
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM Client) -> Exception -> STM Client
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
                    Text
"received senderPromise capability #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
", but the imports table says #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is senderHosted."
            Just ent :: EntryI
ent@EntryI { Word32
remoteRc :: Word32
$sel:remoteRc:EntryI :: EntryI -> Word32
remoteRc, ExportMap
proxies :: ExportMap
$sel:proxies:EntryI :: EntryI -> ExportMap
proxies, $sel:promiseState:EntryI :: EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState=Just (TVar PromiseState
pState, TmpDest
origTarget) } -> do
                EntryI -> IEId -> Map IEId EntryI -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert EntryI
ent { $sel:remoteRc:EntryI :: Word32
remoteRc = Word32
remoteRc Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 } IEId
importId Map IEId EntryI
imports
                Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> STM Client) -> Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just PromiseClient :: TVar PromiseState -> ExportMap -> TmpDest -> Client'
PromiseClient
                    { TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: TVar PromiseState
pState
                    , $sel:exportMap:LocalClient :: ExportMap
exportMap = ExportMap
proxies
                    , TmpDest
origTarget :: TmpDest
$sel:origTarget:LocalClient :: TmpDest
origTarget
                    }
            Maybe EntryI
Nothing -> do
                rec Cell ImportRef
imp <- IEId
-> Conn
-> Maybe (TVar PromiseState, TmpDest)
-> STM (Cell ImportRef)
newImport IEId
importId Conn
conn ((TVar PromiseState, TmpDest) -> Maybe (TVar PromiseState, TmpDest)
forall a. a -> Maybe a
Just (TVar PromiseState
pState, TmpDest
tmpDest))
                    ImportRef{ExportMap
proxies :: ExportMap
$sel:proxies:ImportRef :: ImportRef -> ExportMap
proxies} <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
imp
                    let tmpDest :: TmpDest
tmpDest = RemoteDest -> TmpDest
RemoteDest (Cell ImportRef -> RemoteDest
ImportDest Cell ImportRef
imp)
                    TVar PromiseState
pState <- PromiseState -> STM (TVar PromiseState)
forall a. a -> STM (TVar a)
newTVar Pending :: TmpDest -> PromiseState
Pending { TmpDest
tmpDest :: TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest }
                Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> STM Client) -> Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just PromiseClient :: TVar PromiseState -> ExportMap -> TmpDest -> Client'
PromiseClient
                    { TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: TVar PromiseState
pState
                    , $sel:exportMap:LocalClient :: ExportMap
exportMap = ExportMap
proxies
                    , $sel:origTarget:LocalClient :: TmpDest
origTarget = TmpDest
tmpDest
                    }
    go conn' :: Conn'
conn'@Conn'{Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports} (R.CapDescriptor'receiverHosted Word32
exportId) =
        Text
-> Conn'
-> Map IEId EntryE
-> IEId
-> (EntryE -> STM Client)
-> STM Client
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
"export" Conn'
conn' Map IEId EntryE
exports (Word32 -> IEId
IEId Word32
exportId) ((EntryE -> STM Client) -> STM Client)
-> (EntryE -> STM Client) -> STM Client
forall a b. (a -> b) -> a -> b
$
            \EntryE{Client'
client :: Client'
$sel:client:EntryE :: EntryE -> Client'
client} ->
                Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> STM Client) -> Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just Client'
client
    go Conn'
conn' (R.CapDescriptor'receiverAnswer PromisedAnswer
pa) = do
        PromisedAnswer
pa <- PromisedAnswer -> STM PromisedAnswer
forall (m :: * -> *).
MonadThrow m =>
PromisedAnswer -> m PromisedAnswer
unmarshalPromisedAnswer PromisedAnswer
pa STM PromisedAnswer
-> (Exception -> STM PromisedAnswer) -> STM PromisedAnswer
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
`catchSTM` Conn' -> Exception -> STM PromisedAnswer
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn'
        Conn' -> PromisedAnswer -> STM Client
newLocalAnswerClient Conn'
conn' PromisedAnswer
pa
    go Conn'
conn' (R.CapDescriptor'thirdPartyHosted ThirdPartyCapDescriptor
_) =
        -- Note [Level 3]
        Conn' -> Exception -> STM Client
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM Client) -> Exception -> STM Client
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eUnimplemented
            Text
"thirdPartyHosted unimplemented; level 3 is not supported."
    go Conn'
conn' (R.CapDescriptor'unknown' Word16
tag) =
        Conn' -> Exception -> STM Client
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM Client) -> Exception -> STM Client
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eUnimplemented (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$
            Text
"Unimplemented CapDescriptor variant #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word16 -> String
forall a. Show a => a -> String
show Word16
tag)

-- | Create a new entry in the imports table, with the given import id and
-- 'promiseState', and return a corresponding ImportRef. When the ImportRef is
-- garbage collected, the refcount in the table will be decremented.
newImport :: IEId -> Conn -> Maybe (TVar PromiseState, TmpDest) -> STM (Fin.Cell ImportRef)
newImport :: IEId
-> Conn
-> Maybe (TVar PromiseState, TmpDest)
-> STM (Cell ImportRef)
newImport IEId
importId Conn
conn Maybe (TVar PromiseState, TmpDest)
promiseState = Conn -> STM Conn'
getLive Conn
conn STM Conn'
-> (Conn' -> STM (Cell ImportRef)) -> STM (Cell ImportRef)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \conn' :: Conn'
conn'@Conn'{Map IEId EntryI
imports :: Map IEId EntryI
$sel:imports:Conn' :: Conn' -> Map IEId EntryI
imports} -> do
    Rc ()
localRc <- () -> STM () -> STM (Rc ())
forall a. a -> STM () -> STM (Rc a)
Rc.new () (STM () -> STM (Rc ())) -> STM () -> STM (Rc ())
forall a b. (a -> b) -> a -> b
$ IEId -> Conn' -> STM ()
releaseImport IEId
importId Conn'
conn'
    ExportMap
proxies <- Map Conn IEId -> ExportMap
ExportMap (Map Conn IEId -> ExportMap)
-> STM (Map Conn IEId) -> STM ExportMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map Conn IEId)
forall key value. STM (Map key value)
M.new
    let importRef :: ImportRef
importRef = ImportRef :: Conn -> IEId -> ExportMap -> ImportRef
ImportRef
                { Conn
conn :: Conn
$sel:conn:ImportRef :: Conn
conn
                , IEId
importId :: IEId
$sel:importId:ImportRef :: IEId
importId
                , ExportMap
proxies :: ExportMap
$sel:proxies:ImportRef :: ExportMap
proxies
                }
    EntryI -> IEId -> Map IEId EntryI -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert EntryI :: Rc ()
-> Word32
-> ExportMap
-> Maybe (TVar PromiseState, TmpDest)
-> EntryI
EntryI
        { Rc ()
localRc :: Rc ()
$sel:localRc:EntryI :: Rc ()
localRc
        , $sel:remoteRc:EntryI :: Word32
remoteRc = Word32
1
        , ExportMap
proxies :: ExportMap
$sel:proxies:EntryI :: ExportMap
proxies
        , Maybe (TVar PromiseState, TmpDest)
promiseState :: Maybe (TVar PromiseState, TmpDest)
$sel:promiseState:EntryI :: Maybe (TVar PromiseState, TmpDest)
promiseState
        }
        IEId
importId
        Map IEId EntryI
imports
    Cell ImportRef
cell <- ImportRef -> STM (Cell ImportRef)
forall (m :: * -> *) a. MonadSTM m => a -> m (Cell a)
Fin.newCell ImportRef
importRef
    Conn' -> IO () -> STM ()
queueIO Conn'
conn' (IO () -> STM ()) -> IO () -> STM ()
forall a b. (a -> b) -> a -> b
$ Cell ImportRef -> IO () -> IO ()
forall a. Cell a -> IO () -> IO ()
Fin.addFinalizer Cell ImportRef
cell (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Rc () -> STM ()
forall a. Rc a -> STM ()
Rc.decr Rc ()
localRc
    Cell ImportRef -> STM (Cell ImportRef)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cell ImportRef
cell

-- | Release the identified import. Removes it from the table and sends a release
-- message with the correct count.
releaseImport :: IEId -> Conn' -> STM ()
releaseImport :: IEId -> Conn' -> STM ()
releaseImport IEId
importId conn' :: Conn'
conn'@Conn'{Map IEId EntryI
imports :: Map IEId EntryI
$sel:imports:Conn' :: Conn' -> Map IEId EntryI
imports} = do
    Text
-> Conn' -> Map IEId EntryI -> IEId -> (EntryI -> STM ()) -> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
"imports" Conn'
conn' Map IEId EntryI
imports IEId
importId ((EntryI -> STM ()) -> STM ()) -> (EntryI -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \EntryI { Word32
remoteRc :: Word32
$sel:remoteRc:EntryI :: EntryI -> Word32
remoteRc } ->
        Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Release -> Message
R.Message'release
            Release :: Word32 -> Word32 -> Release
R.Release
                { $sel:id:Release :: Word32
id = IEId -> Word32
ieWord IEId
importId
                , $sel:referenceCount:Release :: Word32
referenceCount = Word32
remoteRc
                }
    IEId -> Map IEId EntryI -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete IEId
importId Map IEId EntryI
imports

-- | Create a new client targeting an object in our answers table.
-- Important: in this case the 'PromisedAnswer' refers to a question we
-- have recevied, not sent.
newLocalAnswerClient :: Conn' -> PromisedAnswer -> STM Client
newLocalAnswerClient :: Conn' -> PromisedAnswer -> STM Client
newLocalAnswerClient conn :: Conn'
conn@Conn'{Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} PromisedAnswer{ QAId
answerId :: QAId
$sel:answerId:PromisedAnswer :: PromisedAnswer -> QAId
answerId, SnocList Word16
transform :: SnocList Word16
$sel:transform:PromisedAnswer :: PromisedAnswer -> SnocList Word16
transform } = do
    TQueue CallInfo
callBuffer <- STM (TQueue CallInfo)
forall a. STM (TQueue a)
newTQueue
    let tmpDest :: TmpDest
tmpDest = LocalDest -> TmpDest
LocalDest (LocalDest -> TmpDest) -> LocalDest -> TmpDest
forall a b. (a -> b) -> a -> b
$ LocalBuffer :: TQueue CallInfo -> LocalDest
LocalBuffer { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: TQueue CallInfo
callBuffer }
    TVar PromiseState
pState <- PromiseState -> STM (TVar PromiseState)
forall a. a -> STM (TVar a)
newTVar Pending :: TmpDest -> PromiseState
Pending { TmpDest
tmpDest :: TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest }
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"answer" Conn'
conn Map QAId EntryQA
answers QAId
answerId ((Return -> STM ()) -> STM ()) -> (Return -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$
        TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn
            TmpDest
tmpDest
            (TVar PromiseState -> PromiseState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState)
            Conn'
conn
            (SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
transform)
    ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap (Map Conn IEId -> ExportMap)
-> STM (Map Conn IEId) -> STM ExportMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map Conn IEId)
forall key value. STM (Map key value)
M.new
    Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> STM Client) -> Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just PromiseClient :: TVar PromiseState -> ExportMap -> TmpDest -> Client'
PromiseClient
        { TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: TVar PromiseState
pState
        , ExportMap
exportMap :: ExportMap
$sel:exportMap:LocalClient :: ExportMap
exportMap
        , $sel:origTarget:LocalClient :: TmpDest
origTarget = TmpDest
tmpDest
        }


-- Note [Limiting resource usage]
-- ==============================
--
-- N.B. much of this Note is future tense; the library is not yet robust against
-- resource useage attacks.
--
-- We employ various strategies to prevent remote vats from causing excessive
-- resource usage. In particular:
--
-- * We set a maximum size for incoming messages; this is in keeping with how
--   we mitigate these concerns when dealing with plain capnp data (i.e. not
--   rpc).
-- * We set a limit on the total *size* of all messages from the remote vat that
--   are currently being serviced. For example, if a Call message comes in,
--   we note its size, and deduct it from the quota. Once we have sent a return
--   and received a finish for this call, and thus can safely forget about it,
--   we remove it from our answers table, and add its size back to the available
--   quota.
--
-- Still TBD:
--
-- * We should come up with some way of guarding against too many intra-vat calls;
--   depending on the object graph, it may be possible for an attacker to get us
--   to "eat our own tail" so to speak.
--
--   Ideas:
--     * Per-object bounded queues for messages
--     * Global limit on intra-vat calls.
--
--   Right now I(zenhack) am more fond of the former.
--
-- * What should we actually do when limits are exceeded?
--
--   Possible strategies:
--     * Block
--     * Throw an 'overloaded' exception
--     * Some combination of the two; block with a timeout, then throw.
--
--   If we just block, we need to make sure this doesn't hang the vat;
--   we probably need a timeout at some level.