{-# 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

    -- * 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 Data.Word

import Control.Concurrent       (threadDelay)
import Control.Concurrent.Async (concurrently_, race_)
import Control.Concurrent.MVar  (MVar, newEmptyMVar)
import Control.Exception.Safe   (Exception, bracket, throwIO, 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)
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)
import Capnp.Convert    (msgToValue, valueToMsg)
import Capnp.Message    (ConstMsg)
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 (defaultLimit, evalLimitT)
import Internal.BuildPure   (createPure)
import Internal.Rc          (Rc)
import Internal.SnocList    (SnocList)

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.Finalizer       as Fin
import qualified Internal.Rc              as Rc
import qualified Internal.SnocList        as SnocList
import qualified Internal.TCloseQ         as TCloseQ

-- 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 MPtr = Maybe Untyped.Ptr
-- | Less often, but still helpful:
type RawMPtr = Maybe (UntypedRaw.Ptr ConstMsg)


-- | 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)

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 show 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 ConstMsg
sendQ            :: TBQueue ConstMsg
    , Conn' -> TBQueue ConstMsg
recvQ            :: TBQueue ConstMsg
    -- 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 ConstMsg
sendQ <- Natural -> STM (TBQueue ConstMsg)
forall a. Natural -> STM (TBQueue a)
newTBQueue (Natural -> STM (TBQueue ConstMsg))
-> Natural -> STM (TBQueue ConstMsg)
forall a b. (a -> b) -> a -> b
$ Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
maxQuestions
            TBQueue ConstMsg
recvQ <- Natural -> STM (TBQueue ConstMsg)
forall a. Natural -> STM (TBQueue a)
newTBQueue (Natural -> STM (TBQueue ConstMsg))
-> Natural -> STM (TBQueue ConstMsg)
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 ConstMsg
-> TBQueue ConstMsg
-> 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 ConstMsg
recvQ :: TBQueue ConstMsg
$sel:recvQ:Conn' :: TBQueue ConstMsg
recvQ
                    , TBQueue ConstMsg
sendQ :: TBQueue ConstMsg
$sel:sendQ:Conn' :: TBQueue ConstMsg
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:
                ConstMsg
rawMsg <- WordCount
-> (forall s. PureBuilder s (Mutable s ConstMsg)) -> IO ConstMsg
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 ConstMsg)) -> IO ConstMsg)
-> (forall s. PureBuilder s (Mutable s ConstMsg)) -> IO ConstMsg
forall a b. (a -> b) -> a -> b
$ Message -> PureBuilder s (MutMsg s)
forall (m :: * -> *) s a.
(MonadLimit m, WriteCtx m s, Cerialize s a,
 ToStruct (MutMsg s) (Cerial (MutMsg s) a)) =>
a -> m (MutMsg s)
valueToMsg (Message -> PureBuilder s (MutMsg s))
-> Message -> PureBuilder s (MutMsg 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 -> ConstMsg -> IO ()
sendMsg Transport
transport ConstMsg
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 Word32
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 :: Word32 -> Bool -> Return' -> Return
R.Return
                            { $sel:answerId:Return :: Word32
answerId = Word32
qid
                            , $sel:releaseParamCaps:Return :: Bool
releaseParamCaps = Bool
False
                            , $sel:union':Return :: Return'
union' = Exception -> Return'
R.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 (R.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 :: R.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 (R.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 MPtr))
    | ReadyPipeline (Either R.Exception MPtr)

-- | '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 MPtr)
subscribers -> do
            (Client
ret, Fulfiller Client
retFulfiller) <- STM (Client, Fulfiller Client)
forall (m :: * -> *) c.
(MonadSTM m, IsClient c) =>
m (c, Fulfiller c)
newPromiseClient
            Fulfiller MPtr
ptrFulfiller <- (Either Exception MPtr -> STM ()) -> STM (Fulfiller MPtr)
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception MPtr -> STM ()) -> STM (Fulfiller MPtr))
-> (Either Exception MPtr -> STM ()) -> STM (Fulfiller MPtr)
forall a b. (a -> b) -> a -> b
$ \Either Exception MPtr
r -> do
                TVar PipelineState -> PipelineState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
state (Either Exception MPtr -> PipelineState
ReadyPipeline Either Exception MPtr
r)
                Fulfiller Client -> Either Exception Client -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
breakOrFulfill Fulfiller Client
retFulfiller (Either Exception MPtr
r Either Exception MPtr
-> (MPtr -> Either Exception MPtr) -> Either Exception MPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Word16] -> MPtr -> Either Exception MPtr
followPtrs (SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
steps) Either Exception MPtr
-> (MPtr -> Either Exception Client) -> Either Exception Client
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MPtr -> Either Exception Client
ptrClient)
            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 MPtr) -> PipelineState
PendingLocalPipeline (SnocList (Fulfiller MPtr) -> PipelineState)
-> SnocList (Fulfiller MPtr) -> PipelineState
forall a b. (a -> b) -> a -> b
$ SnocList (Fulfiller MPtr)
-> Fulfiller MPtr -> SnocList (Fulfiller MPtr)
forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList (Fulfiller MPtr)
subscribers Fulfiller MPtr
ptrFulfiller
            Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
ret
        ReadyPipeline Either Exception MPtr
r ->
            case Either Exception MPtr
r Either Exception MPtr
-> (MPtr -> Either Exception MPtr) -> Either Exception MPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Word16] -> MPtr -> Either Exception MPtr
followPtrs (SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
steps) Either Exception MPtr
-> (MPtr -> Either Exception Client) -> Either Exception Client
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MPtr -> Either Exception Client
ptrClient of
                Right Client
v -> Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
v
                Left Exception
e -> do
                    (Client
p, Fulfiller Client
f) <- STM (Client, Fulfiller Client)
forall (m :: * -> *) c.
(MonadSTM m, IsClient c) =>
m (c, Fulfiller c)
newPromiseClient
                    Fulfiller Client -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller Client
f Exception
e
                    Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
p

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)

-- MsgTarget and PromisedAnswer correspond to the similarly named types in
-- rpc.capnp, except:
--
-- * They use our newtype wrappers for ids
-- * They don't have unknown variants
-- * 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
    }

-- 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 (Maybe (Ptr ConstMsg))
response :: CallInfo -> Fulfiller (Maybe (Ptr ConstMsg))
response :: Fulfiller (Maybe (Ptr ConstMsg))
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 (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
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 MPtr -> PipelineState
ReadyPipeline (Exception -> Either Exception MPtr
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 (Maybe (Ptr ConstMsg))
response :: Fulfiller (Maybe (Ptr ConstMsg))
response :: CallInfo -> Fulfiller (Maybe (Ptr ConstMsg))
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 (Maybe (Ptr ConstMsg))
response') <- Fulfiller (Maybe (Ptr ConstMsg))
-> STM (Pipeline, Fulfiller (Maybe (Ptr ConstMsg)))
makeLocalPipeline Fulfiller (Maybe (Ptr ConstMsg))
response
    let info' :: CallInfo
info' = CallInfo
info { response :: Fulfiller (Maybe (Ptr ConstMsg))
Server.response = Fulfiller (Maybe (Ptr ConstMsg))
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 (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
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.get Cell ImportRef
cell
                    Conn -> CallInfo -> MsgTarget -> STM Pipeline
callRemote Conn
conn CallInfo
info (IEId -> MsgTarget
ImportTgt IEId
importId)

            Error Exception
exn -> do
                Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
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.get 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 (Maybe (Ptr ConstMsg))
-> STM (Pipeline, Fulfiller (Maybe (Ptr ConstMsg)))
makeLocalPipeline Fulfiller (Maybe (Ptr ConstMsg))
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 MPtr) -> PipelineState
PendingLocalPipeline SnocList (Fulfiller MPtr)
forall a. Monoid a => a
mempty
    Fulfiller (Maybe (Ptr ConstMsg))
f' <- (Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
-> STM (Fulfiller (Maybe (Ptr ConstMsg)))
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
 -> STM (Fulfiller (Maybe (Ptr ConstMsg))))
-> (Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
-> STM (Fulfiller (Maybe (Ptr ConstMsg)))
forall a b. (a -> b) -> a -> b
$ \Either Exception (Maybe (Ptr ConstMsg))
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 MPtr)
fs -> do
                Either Exception MPtr
pr <- case Either Exception (Maybe (Ptr ConstMsg))
r of
                    Left Exception
e  -> Either Exception MPtr -> STM (Either Exception MPtr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exception -> Either Exception MPtr
forall a b. a -> Either a b
Left Exception
e)
                    Right Maybe (Ptr ConstMsg)
v -> MPtr -> Either Exception MPtr
forall a b. b -> Either a b
Right (MPtr -> Either Exception MPtr)
-> STM MPtr -> STM (Either Exception MPtr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WordCount -> LimitT STM MPtr -> STM MPtr
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (Cerial ConstMsg MPtr -> LimitT STM MPtr
forall a (m :: * -> *).
(Decerialize a, ReadCtx m ConstMsg) =>
Cerial ConstMsg a -> m a
decerialize Maybe (Ptr ConstMsg)
Cerial ConstMsg MPtr
v)
                TVar PipelineState -> PipelineState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
state (Either Exception MPtr -> PipelineState
ReadyPipeline Either Exception MPtr
pr)
                Fulfiller (Maybe (Ptr ConstMsg))
-> Either Exception (Maybe (Ptr ConstMsg)) -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
breakOrFulfill Fulfiller (Maybe (Ptr ConstMsg))
f Either Exception (Maybe (Ptr ConstMsg))
r
                (Fulfiller MPtr -> STM ()) -> SnocList (Fulfiller MPtr) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Fulfiller MPtr -> Either Exception MPtr -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
`breakOrFulfill` Either Exception MPtr
pr) SnocList (Fulfiller MPtr)
fs
            PipelineState
_ ->
                -- TODO(cleanup): refactor so we don't need this case.
                String -> STM ()
forall a. HasCallStack => String -> a
error String
"impossible"
    (Pipeline, Fulfiller (Maybe (Ptr ConstMsg)))
-> STM (Pipeline, Fulfiller (Maybe (Ptr ConstMsg)))
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 (Maybe (Ptr ConstMsg))
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, Maybe (Ptr ConstMsg)
arguments :: CallInfo -> Maybe (Ptr ConstMsg)
arguments :: Maybe (Ptr ConstMsg)
arguments, Fulfiller (Maybe (Ptr ConstMsg))
response :: Fulfiller (Maybe (Ptr ConstMsg))
response :: CallInfo -> Fulfiller (Maybe (Ptr ConstMsg))
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@R.Payload{Vector CapDescriptor
$sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable :: Vector CapDescriptor
capTable} <- Conn -> Maybe (Ptr ConstMsg) -> STM Payload
makeOutgoingPayload Conn
conn Maybe (Ptr ConstMsg)
arguments
    Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Call -> Message
R.Message'call Call
forall a. Default a => a
def
        { $sel:questionId:Call :: Word32
R.questionId = QAId -> Word32
qaWord QAId
qid
        , $sel:target:Call :: MessageTarget
R.target = MsgTarget -> MessageTarget
marshalMsgTarget MsgTarget
target
        , $sel:params:Call :: Payload
R.params = Payload
payload
        , $sel:interfaceId:Call :: Word64
R.interfaceId = Word64
interfaceId
        , $sel:methodId:Call :: Word16
R.methodId = 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 (Maybe (Ptr ConstMsg))
response' <- (Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
-> STM (Fulfiller (Maybe (Ptr ConstMsg)))
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
 -> STM (Fulfiller (Maybe (Ptr ConstMsg))))
-> (Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
-> STM (Fulfiller (Maybe (Ptr ConstMsg)))
forall a b. (a -> b) -> a -> b
$ \Either Exception (Maybe (Ptr ConstMsg))
r -> do
        Fulfiller (Maybe (Ptr ConstMsg))
-> Either Exception (Maybe (Ptr ConstMsg)) -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either Exception a -> m ()
breakOrFulfill Fulfiller (Maybe (Ptr ConstMsg))
response Either Exception (Maybe (Ptr ConstMsg))
r
        case Either Exception (Maybe (Ptr ConstMsg))
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 MPtr -> PipelineState
ReadyPipeline (Exception -> Either Exception MPtr
forall a b. a -> Either a b
Left Exception
e)
            Right Maybe (Ptr ConstMsg)
v -> do
                MPtr
content <- WordCount -> LimitT STM MPtr -> STM MPtr
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (Cerial ConstMsg MPtr -> LimitT STM MPtr
forall a (m :: * -> *).
(Decerialize a, ReadCtx m ConstMsg) =>
Cerial ConstMsg a -> m a
decerialize Maybe (Ptr ConstMsg)
Cerial ConstMsg MPtr
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 MPtr -> PipelineState
ReadyPipeline (MPtr -> Either Exception MPtr
forall a b. b -> Either a b
Right MPtr
content)

    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 (Maybe (Ptr ConstMsg)) -> Return -> STM ()
cbCallReturn [IEId]
paramCaps Conn
conn Fulfiller (Maybe (Ptr ConstMsg))
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 -> R.Return -> STM ()
cbCallReturn :: [IEId]
-> Conn -> Fulfiller (Maybe (Ptr ConstMsg)) -> Return -> STM ()
cbCallReturn
        [IEId]
paramCaps
        Conn
conn
        Fulfiller (Maybe (Ptr ConstMsg))
response
        R.Return{ Word32
answerId :: Word32
$sel:answerId:Return :: Return -> Word32
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
        R.Return'exception Exception
exn ->
            Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
response Exception
exn
        R.Return'results R.Payload{ MPtr
$sel:content:Payload :: Payload -> MPtr
content :: MPtr
content } -> do
            Maybe (Ptr ConstMsg)
rawPtr <- WordCount
-> (forall s. PureBuilder s (Mutable s (Maybe (Ptr ConstMsg))))
-> STM (Maybe (Ptr ConstMsg))
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 (Maybe (Ptr ConstMsg))))
 -> STM (Maybe (Ptr ConstMsg)))
-> (forall s. PureBuilder s (Mutable s (Maybe (Ptr ConstMsg))))
-> STM (Maybe (Ptr ConstMsg))
forall a b. (a -> b) -> a -> b
$ do
                MutMsg s
msg <- Maybe WordCount -> PureBuilder s (MutMsg s)
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (MutMsg s)
Message.newMessage Maybe WordCount
forall a. Maybe a
Nothing
                MutMsg s -> MPtr -> PureBuilder s (Cerial (MutMsg s) MPtr)
forall s a (m :: * -> *).
(Cerialize s a, RWCtx m s) =>
MutMsg s -> a -> m (Cerial (MutMsg s) a)
cerialize MutMsg s
msg MPtr
content
            Fulfiller (Maybe (Ptr ConstMsg)) -> Maybe (Ptr ConstMsg) -> STM ()
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller (Maybe (Ptr ConstMsg))
response Maybe (Ptr ConstMsg)
rawPtr
        Return'
R.Return'canceled ->
            Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
response (Exception -> STM ()) -> Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Exception
eFailed Text
"Canceled"

        Return'
R.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."
                ]

        R.Return'takeFromOtherQuestion (Word32 -> QAId
QAId -> 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 (Maybe (Ptr ConstMsg)) -> Return -> STM ()
cbCallReturn [] Conn
conn Fulfiller (Maybe (Ptr ConstMsg))
response

        R.Return'acceptFromThirdParty MPtr
_ ->
            -- 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."
        R.Return'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 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)
    -- Defer this until after any other callbacks run, in case disembargos
    -- need to be send 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 = Word32
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 :: R.PromisedAnswer -> Either R.Exception PromisedAnswer
unmarshalPromisedAnswer :: PromisedAnswer -> Either Exception 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] -> Either Exception [Word16]
unmarshalOps (Vector PromisedAnswer'Op -> [PromisedAnswer'Op]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector PromisedAnswer'Op
transform)
    PromisedAnswer -> Either Exception 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 :: [R.PromisedAnswer'Op] -> Either R.Exception [Word16]
unmarshalOps :: [PromisedAnswer'Op] -> Either Exception [Word16]
unmarshalOps [] = [Word16] -> Either Exception [Word16]
forall a b. b -> Either a b
Right []
unmarshalOps (PromisedAnswer'Op
R.PromisedAnswer'Op'noop:[PromisedAnswer'Op]
ops) =
    [PromisedAnswer'Op] -> Either Exception [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])
-> Either Exception [Word16] -> Either Exception [Word16]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PromisedAnswer'Op] -> Either Exception [Word16]
unmarshalOps [PromisedAnswer'Op]
ops
unmarshalOps (R.PromisedAnswer'Op'unknown' Word16
tag:[PromisedAnswer'Op]
_) =
    Exception -> Either Exception [Word16]
forall a b. a -> Either a b
Left (Exception -> Either Exception [Word16])
-> Exception -> Either Exception [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 a. a -> STM (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 (IO () -> STM ()) -> IO () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
        Cell () -> STM () -> IO ()
forall a. Cell a -> STM () -> IO ()
Fin.addFinalizer Cell ()
finalizerKey (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
    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 (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
-> MethodHandler IO p r
forall (m :: * -> *) p r.
MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
-> MethodHandler m p r
Server.fromUntypedHandler (MethodHandler IO (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
 -> MethodHandler IO p r)
-> MethodHandler IO (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
-> MethodHandler IO p r
forall a b. (a -> b) -> a -> b
$ (Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> IO ())
-> MethodHandler IO (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
forall (m :: * -> *).
(Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
Server.untypedHandler ((Maybe (Ptr ConstMsg)
  -> Fulfiller (Maybe (Ptr ConstMsg)) -> IO ())
 -> MethodHandler IO (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg)))
-> (Maybe (Ptr ConstMsg)
    -> Fulfiller (Maybe (Ptr ConstMsg)) -> IO ())
-> MethodHandler IO (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
forall a b. (a -> b) -> a -> b
$
        \Maybe (Ptr ConstMsg)
arguments Fulfiller (Maybe (Ptr ConstMsg))
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
-> Maybe (Ptr ConstMsg)
-> Fulfiller (Maybe (Ptr ConstMsg))
-> CallInfo
Server.CallInfo{Maybe (Ptr ConstMsg)
Word16
Word64
Fulfiller (Maybe (Ptr ConstMsg))
response :: Fulfiller (Maybe (Ptr ConstMsg))
arguments :: Maybe (Ptr ConstMsg)
methodId :: Word16
interfaceId :: Word64
arguments :: Maybe (Ptr ConstMsg)
methodId :: Word16
interfaceId :: Word64
response :: Fulfiller (Maybe (Ptr ConstMsg))
..} 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 ConstMsg
sendQ :: TBQueue ConstMsg
$sel:sendQ:Conn' :: Conn' -> TBQueue ConstMsg
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 ConstMsg -> IO ConstMsg
forall a. STM a -> IO a
atomically (TBQueue ConstMsg -> STM ConstMsg
forall a. TBQueue a -> STM a
readTBQueue TBQueue ConstMsg
sendQ) IO ConstMsg -> (ConstMsg -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Transport -> ConstMsg -> 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 ConstMsg
recvQ :: TBQueue ConstMsg
$sel:recvQ:Conn' :: Conn' -> TBQueue ConstMsg
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 ConstMsg
recvMsg Transport
transport IO ConstMsg -> (ConstMsg -> 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 ()) -> (ConstMsg -> STM ()) -> ConstMsg -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue ConstMsg -> ConstMsg -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ConstMsg
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 ConstMsg
recvQ :: TBQueue ConstMsg
$sel:recvQ:Conn' :: Conn' -> TBQueue ConstMsg
recvQ} <- Conn -> STM Conn'
getLive Conn
conn
    Message
msg <- (TBQueue ConstMsg -> STM ConstMsg
forall a. TBQueue a -> STM a
readTBQueue TBQueue ConstMsg
recvQ STM ConstMsg -> (ConstMsg -> STM Message) -> STM Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Conn -> ConstMsg -> STM Message
parseWithCaps Conn
conn)
        STM Message -> (SomeException -> STM Message) -> STM Message
forall e a. Exception e => STM a -> (e -> STM a) -> STM a
`catchSTM`
        (Conn' -> Exception -> STM Message
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' (Exception -> STM Message)
-> (SomeException -> Exception) -> SomeException -> STM Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SomeException -> Exception
wrapException Bool
debugMode)
    case Message
msg of
        R.Message'abort Exception
exn ->
            Conn -> Exception -> STM ()
handleAbortMsg Conn
conn Exception
exn
        R.Message'unimplemented Message
oldMsg ->
            Conn -> Message -> STM ()
handleUnimplementedMsg Conn
conn Message
oldMsg
        R.Message'bootstrap Bootstrap
bs ->
            Conn -> Bootstrap -> STM ()
handleBootstrapMsg Conn
conn Bootstrap
bs
        R.Message'call Call
call ->
            Conn -> Call -> STM ()
handleCallMsg Conn
conn Call
call
        R.Message'return Return
ret ->
            Conn -> Return -> STM ()
handleReturnMsg Conn
conn Return
ret
        R.Message'finish Finish
finish ->
            Conn -> Finish -> STM ()
handleFinishMsg Conn
conn Finish
finish
        R.Message'resolve Resolve
res ->
            Conn -> Resolve -> STM ()
handleResolveMsg Conn
conn Resolve
res
        R.Message'release Release
release ->
            Conn -> Release -> STM ()
handleReleaseMsg Conn
conn Release
release
        R.Message'disembargo Disembargo
disembargo ->
            Conn -> Disembargo -> STM ()
handleDisembargoMsg Conn
conn Disembargo
disembargo
        Message
_ ->
            Conn' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Message -> Message
R.Message'unimplemented Message
msg

-- | 'parseWithCaps' parses a message, making sure to interpret its capability
-- table. The latter bit is the difference between this and just calling
-- 'msgToValue'; 'msgToValue' will leave all of the clients in the message
-- null.
parseWithCaps :: Conn -> ConstMsg -> STM R.Message
parseWithCaps :: Conn -> ConstMsg -> STM Message
parseWithCaps Conn
conn ConstMsg
msg = do
    Message
pureMsg <- ConstMsg -> STM Message
forall (m :: * -> *) msg a.
(MonadThrow m, Message (LimitT m) msg, Message m msg,
 FromStruct msg a) =>
msg -> m a
msgToValue ConstMsg
msg
    case Message
pureMsg of
        -- capabilities only appear in call and return messages, and in the
        -- latter only in the 'results' variant. In the other cases we can
        -- just leave the result alone.
        R.Message'call R.Call{$sel:params:Call :: Call -> Payload
params=R.Payload{Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable}} ->
            Vector CapDescriptor -> Conn -> ConstMsg -> STM ConstMsg
fixCapTable Vector CapDescriptor
capTable Conn
conn ConstMsg
msg STM ConstMsg -> (ConstMsg -> STM Message) -> STM Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConstMsg -> STM Message
forall (m :: * -> *) msg a.
(MonadThrow m, Message (LimitT m) msg, Message m msg,
 FromStruct msg a) =>
msg -> m a
msgToValue
        R.Message'return R.Return{$sel:union':Return :: Return -> Return'
union'=R.Return'results R.Payload{Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable}} ->
            Vector CapDescriptor -> Conn -> ConstMsg -> STM ConstMsg
fixCapTable Vector CapDescriptor
capTable Conn
conn ConstMsg
msg STM ConstMsg -> (ConstMsg -> STM Message) -> STM Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConstMsg -> STM Message
forall (m :: * -> *) msg a.
(MonadThrow m, Message (LimitT m) msg, Message m msg,
 FromStruct msg a) =>
msg -> m a
msgToValue
        Message
_ ->
            Message -> STM Message
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message
pureMsg

-- 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 -> STM Return) -> Return -> STM Return
forall a b. (a -> b) -> a -> b
$ Return :: Word32 -> Bool -> Return' -> Return
R.Return
                { $sel:answerId:Return :: Word32
R.answerId = Word32
questionId
                , $sel:releaseParamCaps:Return :: Bool
R.releaseParamCaps = Bool
True -- Not really meaningful for bootstrap, but...
                , $sel:union':Return :: Return'
R.union' =
                    Exception -> Return'
R.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
            Return -> STM Return
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Return -> STM Return) -> Return -> STM Return
forall a b. (a -> b) -> a -> b
$ Return :: Word32 -> Bool -> Return' -> Return
R.Return
                { $sel:answerId:Return :: Word32
R.answerId = Word32
questionId
                , $sel:releaseParamCaps:Return :: Bool
R.releaseParamCaps = Bool
True -- Not really meaningful for bootstrap, but...
                , $sel:union':Return :: Return'
R.union' =
                    Payload -> Return'
R.Return'results Payload :: MPtr -> Vector CapDescriptor -> Payload
R.Payload
                            -- XXX: this is a bit fragile; we're relying on
                            -- the encode step to pick the right index for
                            -- our capability.
                        { $sel:content:Payload :: MPtr
content = Ptr -> MPtr
forall a. a -> Maybe a
Just (Client -> Ptr
Untyped.PtrCap Client
client)
                        , $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' -> Message -> STM ()
sendPureMsg Conn'
conn' (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Return -> Message
R.Message'return 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
                        R.Return
                            { $sel:union':Return :: Return -> Return'
union' = R.Return'results R.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 -> R.Call -> STM ()
handleCallMsg :: Conn -> Call -> STM ()
handleCallMsg
        Conn
conn
        R.Call
            { Word32
questionId :: Word32
$sel:questionId:Call :: Call -> Word32
questionId
            , MessageTarget
target :: MessageTarget
$sel:target:Call :: Call -> MessageTarget
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=R.Payload{MPtr
content :: MPtr
$sel:content:Payload :: Payload -> MPtr
content, Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Payload -> Vector CapDescriptor
capTable}
            }
        = 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, Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} -> 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

    -- Marshal the parameters to the call back into the low-level form:
    Maybe (Ptr ConstMsg)
callParams <- WordCount
-> (forall s. PureBuilder s (Mutable s (Maybe (Ptr ConstMsg))))
-> STM (Maybe (Ptr ConstMsg))
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 (Maybe (Ptr ConstMsg))))
 -> STM (Maybe (Ptr ConstMsg)))
-> (forall s. PureBuilder s (Mutable s (Maybe (Ptr ConstMsg))))
-> STM (Maybe (Ptr ConstMsg))
forall a b. (a -> b) -> a -> b
$ do
        MutMsg s
msg <- Maybe WordCount -> PureBuilder s (MutMsg s)
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (MutMsg s)
Message.newMessage Maybe WordCount
forall a. Maybe a
Nothing
        MutMsg s -> MPtr -> PureBuilder s (Cerial (MutMsg s) MPtr)
forall s a (m :: * -> *).
(Cerialize s a, RWCtx m s) =>
MutMsg s -> a -> m (Cerial (MutMsg s) a)
cerialize MutMsg s
msg MPtr
content

    -- Set up a callback for when the call is finished, to
    -- send the return message:
    Fulfiller (Maybe (Ptr ConstMsg))
fulfiller <- (Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
-> STM (Fulfiller (Maybe (Ptr ConstMsg)))
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
 -> STM (Fulfiller (Maybe (Ptr ConstMsg))))
-> (Either Exception (Maybe (Ptr ConstMsg)) -> STM ())
-> STM (Fulfiller (Maybe (Ptr ConstMsg)))
forall a b. (a -> b) -> a -> b
$ \case
        Left Exception
e ->
            Conn' -> Return -> STM ()
returnAnswer Conn'
conn' Return
forall a. Default a => a
def
                { $sel:answerId:Return :: Word32
R.answerId = Word32
questionId
                , $sel:releaseParamCaps:Return :: Bool
R.releaseParamCaps = Bool
False
                , $sel:union':Return :: Return'
R.union' = Exception -> Return'
R.Return'exception Exception
e
                }
        Right Maybe (Ptr ConstMsg)
v -> do
            MPtr
content <- WordCount -> LimitT STM MPtr -> STM MPtr
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (Cerial ConstMsg MPtr -> LimitT STM MPtr
forall a (m :: * -> *).
(Decerialize a, ReadCtx m ConstMsg) =>
Cerial ConstMsg a -> m a
decerialize Maybe (Ptr ConstMsg)
Cerial ConstMsg MPtr
v)
            Vector CapDescriptor
capTable <- Conn -> MPtr -> STM (Vector CapDescriptor)
genSendableCapTable Conn
conn MPtr
content
            Conn' -> Return -> STM ()
returnAnswer Conn'
conn' Return
forall a. Default a => a
def
                { $sel:answerId:Return :: Word32
R.answerId = Word32
questionId
                , $sel:releaseParamCaps:Return :: Bool
R.releaseParamCaps = Bool
False
                , $sel:union':Return :: Return'
R.union'   = Payload -> Return'
R.Return'results Payload
forall a. Default a => a
def
                    { $sel:content:Payload :: MPtr
R.content  = MPtr
content
                    , $sel:capTable:Payload :: Vector CapDescriptor
R.capTable = Vector CapDescriptor
capTable
                    }
                }
    -- Package up the info for the call:
    let callInfo :: CallInfo
callInfo = CallInfo :: Word64
-> Word16
-> Maybe (Ptr ConstMsg)
-> Fulfiller (Maybe (Ptr ConstMsg))
-> CallInfo
Server.CallInfo
            { Word64
interfaceId :: Word64
interfaceId :: Word64
interfaceId
            , Word16
methodId :: Word16
methodId :: Word16
methodId
            , arguments :: Maybe (Ptr ConstMsg)
arguments = Maybe (Ptr ConstMsg)
callParams
            , response :: Fulfiller (Maybe (Ptr ConstMsg))
response = Fulfiller (Maybe (Ptr ConstMsg))
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@R.Return{Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union'} =
                    case Return'
union' of
                        R.Return'exception Exception
_ ->
                            Conn' -> Return -> STM ()
returnAnswer Conn'
conn' Return
ret { $sel:answerId:Return :: Word32
R.answerId = Word32
questionId }
                        Return'
R.Return'canceled ->
                            Conn' -> Return -> STM ()
returnAnswer Conn'
conn' Return
ret { $sel:answerId:Return :: Word32
R.answerId = Word32
questionId }
                        R.Return'results R.Payload{MPtr
content :: MPtr
$sel:content:Payload :: Payload -> MPtr
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 -> MPtr -> Conn' -> STM Client
transformClient Vector PromisedAnswer'Op
transform MPtr
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'
R.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"
                        R.Return'takeFromOtherQuestion Word32
otherQid ->
                            Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"answer" Conn'
conn' Map QAId EntryQA
answers (Word32 -> QAId
QAId Word32
otherQid) Return -> STM ()
onReturn
                        R.Return'acceptFromThirdParty MPtr
_ ->
                            -- Note [Level 3]
                            String -> STM ()
forall a. HasCallStack => String -> a
error String
"BUG: our implementation unexpectedly used a level 3 feature"
                        R.Return'unknown' Word16
tag ->
                            String -> STM ()
forall a. HasCallStack => String -> a
error (String -> STM ()) -> String -> STM ()
forall a b. (a -> b) -> a -> b
$
                                String
"BUG: our implemented unexpectedly returned unknown " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                String
"result variant #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
tag
            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)

transformClient :: V.Vector R.PromisedAnswer'Op -> MPtr -> Conn' -> STM Client
transformClient :: Vector PromisedAnswer'Op -> MPtr -> Conn' -> STM Client
transformClient Vector PromisedAnswer'Op
transform MPtr
ptr Conn'
conn =
    case [PromisedAnswer'Op] -> Either Exception [Word16]
unmarshalOps (Vector PromisedAnswer'Op -> [PromisedAnswer'Op]
forall a. Vector a -> [a]
V.toList Vector PromisedAnswer'Op
transform) Either Exception [Word16]
-> ([Word16] -> Either Exception MPtr) -> Either Exception MPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Word16] -> MPtr -> Either Exception MPtr)
-> MPtr -> [Word16] -> Either Exception MPtr
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Word16] -> MPtr -> Either Exception MPtr
followPtrs MPtr
ptr Either Exception MPtr
-> (MPtr -> Either Exception Client) -> Either Exception Client
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MPtr -> Either Exception Client
ptrClient of
        Left Exception
e ->
            Conn' -> Exception -> STM Client
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn Exception
e
        Right Client
client ->
            Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
client

ptrClient :: MPtr -> Either R.Exception Client
ptrClient :: MPtr -> Either Exception Client
ptrClient MPtr
Nothing = Client -> Either Exception Client
forall a b. b -> Either a b
Right Client
nullClient
ptrClient (Just (Untyped.PtrCap Client
client)) = Client -> Either Exception Client
forall a b. b -> Either a b
Right Client
client
ptrClient (Just Ptr
_) = Exception -> Either Exception Client
forall a b. a -> Either a b
Left (Exception -> Either Exception Client)
-> Exception -> Either Exception 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 :: [Word16] -> MPtr -> Either R.Exception MPtr
followPtrs :: [Word16] -> MPtr -> Either Exception MPtr
followPtrs [] MPtr
ptr =
    MPtr -> Either Exception MPtr
forall a b. b -> Either a b
Right MPtr
ptr
followPtrs (Word16
_:[Word16]
_) MPtr
Nothing =
    MPtr -> Either Exception MPtr
forall a b. b -> Either a b
Right MPtr
forall a. Maybe a
Nothing
followPtrs (Word16
i:[Word16]
is) (Just (Untyped.PtrStruct (Untyped.Struct Slice Word64
_ Slice MPtr
ptrs))) =
    [Word16] -> MPtr -> Either Exception MPtr
followPtrs [Word16]
is (Int -> Slice MPtr -> MPtr
forall a. Default a => Int -> Slice a -> a
Untyped.sliceIndex (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i) Slice MPtr
ptrs)
followPtrs (Word16
_:[Word16]
_) (Just Ptr
_) =
    Exception -> Either Exception MPtr
forall a b. a -> Either a b
Left (Text -> Exception
eFailed Text
"Tried to access pointer field of non-struct.")

handleReturnMsg :: Conn -> R.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=R.Return{$sel:union':Return :: Return -> Return'
union'=R.Return'results R.Payload{MPtr
content :: MPtr
$sel:content:Payload :: Payload -> MPtr
content} } } ->
                        Vector PromisedAnswer'Op -> MPtr -> Conn' -> STM Client
transformClient Vector PromisedAnswer'Op
transform MPtr
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.get 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



-- | Interpret the list of cap descriptors, and replace the message's capability
-- table with the result.
fixCapTable :: V.Vector R.CapDescriptor -> Conn -> ConstMsg -> STM ConstMsg
fixCapTable :: Vector CapDescriptor -> Conn -> ConstMsg -> STM ConstMsg
fixCapTable Vector CapDescriptor
capDescs Conn
conn ConstMsg
msg = do
    Vector Client
clients <- (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
capDescs
    ConstMsg -> STM ConstMsg
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstMsg -> STM ConstMsg) -> ConstMsg -> STM ConstMsg
forall a b. (a -> b) -> a -> b
$ Vector Client -> ConstMsg -> ConstMsg
Message.withCapTable Vector Client
clients ConstMsg
msg

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.
--
-- XXX: it's kinda gross that we're serializing the pointer just to collect
-- this, then decerializing to put it in the larger adt, then reserializing
-- again... at some point we'll probably want to overhaul much of this module
-- for performance. This kind of thing is the motivation for #52.
genSendableCapTable :: Conn -> MPtr -> STM (V.Vector R.CapDescriptor)
genSendableCapTable :: Conn -> MPtr -> STM (Vector CapDescriptor)
genSendableCapTable Conn
conn MPtr
ptr = do
    Maybe (Ptr ConstMsg)
rawPtr <- WordCount
-> (forall s. PureBuilder s (Mutable s (Maybe (Ptr ConstMsg))))
-> STM (Maybe (Ptr ConstMsg))
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 (Maybe (Ptr ConstMsg))))
 -> STM (Maybe (Ptr ConstMsg)))
-> (forall s. PureBuilder s (Mutable s (Maybe (Ptr ConstMsg))))
-> STM (Maybe (Ptr ConstMsg))
forall a b. (a -> b) -> a -> b
$ do
        MutMsg s
msg <- Maybe WordCount -> PureBuilder s (MutMsg s)
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (MutMsg s)
Message.newMessage Maybe WordCount
forall a. Maybe a
Nothing
        MutMsg s -> MPtr -> PureBuilder s (Cerial (MutMsg s) MPtr)
forall s a (m :: * -> *).
(Cerialize s a, RWCtx m s) =>
MutMsg s -> a -> m (Cerial (MutMsg s) a)
cerialize MutMsg s
msg MPtr
ptr
    Conn -> Maybe (Ptr ConstMsg) -> STM (Vector CapDescriptor)
genSendableCapTableRaw Conn
conn Maybe (Ptr ConstMsg)
rawPtr

genSendableCapTableRaw
    :: Conn
    -> Maybe (UntypedRaw.Ptr ConstMsg)
    -> STM (V.Vector R.CapDescriptor)
genSendableCapTableRaw :: Conn -> Maybe (Ptr ConstMsg) -> STM (Vector CapDescriptor)
genSendableCapTableRaw Conn
_ Maybe (Ptr ConstMsg)
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 ConstMsg
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' }
        )
        (ConstMsg -> Vector Client
Message.getCapTable (Ptr ConstMsg -> InMessage (Ptr ConstMsg)
forall a. HasMessage a => a -> InMessage a
UntypedRaw.message Ptr ConstMsg
ptr))

-- | Convert the pointer into a Payload, including a capability table for
-- the clients in the pointer's cap table.
makeOutgoingPayload :: Conn -> RawMPtr -> STM R.Payload
makeOutgoingPayload :: Conn -> Maybe (Ptr ConstMsg) -> STM Payload
makeOutgoingPayload Conn
conn Maybe (Ptr ConstMsg)
rawContent = do
    Vector CapDescriptor
capTable <- Conn -> Maybe (Ptr ConstMsg) -> STM (Vector CapDescriptor)
genSendableCapTableRaw Conn
conn Maybe (Ptr ConstMsg)
rawContent
    MPtr
content <- WordCount -> LimitT STM MPtr -> STM MPtr
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (Cerial ConstMsg MPtr -> LimitT STM MPtr
forall a (m :: * -> *).
(Decerialize a, ReadCtx m ConstMsg) =>
Cerial ConstMsg a -> m a
decerialize Maybe (Ptr ConstMsg)
Cerial ConstMsg MPtr
rawContent)
    Payload -> STM Payload
forall (f :: * -> *) a. Applicative f => a -> f a
pure Payload :: MPtr -> Vector CapDescriptor -> Payload
R.Payload { MPtr
content :: MPtr
$sel:content:Payload :: MPtr
content, Vector CapDescriptor
capTable :: Vector CapDescriptor
$sel:capTable:Payload :: Vector CapDescriptor
capTable }

sendPureMsg :: Conn' -> R.Message -> STM ()
sendPureMsg :: Conn' -> Message -> STM ()
sendPureMsg Conn'{TBQueue ConstMsg
sendQ :: TBQueue ConstMsg
$sel:sendQ:Conn' :: Conn' -> TBQueue ConstMsg
sendQ} Message
msg =
    WordCount
-> (forall s. PureBuilder s (Mutable s ConstMsg)) -> STM ConstMsg
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 (MutMsg s)
forall (m :: * -> *) s a.
(MonadLimit m, WriteCtx m s, Cerialize s a,
 ToStruct (MutMsg s) (Cerial (MutMsg s) a)) =>
a -> m (MutMsg s)
valueToMsg Message
msg) STM ConstMsg -> (ConstMsg -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TBQueue ConstMsg -> ConstMsg -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue ConstMsg
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' -> R.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' -> Message -> STM ()
sendPureMsg Conn'
conn (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Return -> Message
R.Message'return 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 -> R.Return -> STM ()
updateQAReturn :: Conn' -> Map QAId EntryQA -> Text -> Return -> STM ()
updateQAReturn Conn'
conn Map QAId EntryQA
table Text
tableName ret :: Return
ret@R.Return{Word32
answerId :: Word32
$sel:answerId:Return :: Return -> Word32
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 (Word32 -> QAId
QAId Word32
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
            Conn' -> SnocList (Return -> STM ()) -> Return -> STM ()
forall a. Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM Conn'
conn SnocList (Return -> STM ())
onReturn Return
ret
            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
                    }
                (Word32 -> QAId
QAId Word32
answerId)
                Map QAId EntryQA
table
        HaveFinish{SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} -> do
            Conn' -> SnocList (Return -> STM ()) -> Return -> STM ()
forall a. Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM Conn'
conn SnocList (Return -> STM ())
onReturn Return
ret
            QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete (Word32 -> QAId
QAId Word32
answerId) Map QAId EntryQA
table
        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 (Word32 -> String
forall a. Show a => a -> String
show Word32
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
            Conn' -> SnocList (Finish -> STM ()) -> Finish -> STM ()
forall a. Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM Conn'
conn SnocList (Finish -> STM ())
onFinish Finish
finish
            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
            Conn' -> SnocList (Finish -> STM ()) -> Finish -> STM ()
forall a. Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM Conn'
conn SnocList (Finish -> STM ())
onFinish Finish
finish
            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 -> (R.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.singleton ((Return -> STM ()) -> SnocList (Return -> STM ()))
-> (Return -> STM ()) -> SnocList (Return -> 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' []
                , $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 (Maybe (Ptr ConstMsg))
response :: Fulfiller (Maybe (Ptr ConstMsg))
response :: CallInfo -> Fulfiller (Maybe (Ptr ConstMsg))
response} ->
                    Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
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 ()) -> MPtr -> STM ()
resolveClientPtr :: TmpDest -> (PromiseState -> STM ()) -> MPtr -> STM ()
resolveClientPtr TmpDest
tmpDest PromiseState -> STM ()
resolve MPtr
ptr = case MPtr
ptr of
    MPtr
Nothing ->
        TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest PromiseState -> STM ()
resolve Client
nullClient
    Just (Untyped.PtrCap Client
c) ->
        TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest PromiseState -> STM ()
resolve Client
c
    Just Ptr
_ ->
        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 ()
releaseAndResolve
                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.get 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 ()
releaseAndResolve
                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.get 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.get 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

    releaseAndResolve :: STM ()
releaseAndResolve = do
        TmpDest -> STM ()
releaseTmpDest TmpDest
tmpDest
        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 (Maybe (Ptr ConstMsg))
response :: Fulfiller (Maybe (Ptr ConstMsg))
response :: CallInfo -> Fulfiller (Maybe (Ptr ConstMsg))
response} -> Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
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)
        }

-- Do any cleanup of a TmpDest; this should be called after resolving a
-- pending promise.
releaseTmpDest :: TmpDest -> STM ()
releaseTmpDest :: TmpDest -> STM ()
releaseTmpDest (LocalDest LocalBuffer{}) = () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
releaseTmpDest (RemoteDest AnswerDest { Conn
conn :: Conn
$sel:conn:AnswerDest :: RemoteDest -> Conn
conn, $sel:answer:AnswerDest :: RemoteDest -> PromisedAnswer
answer=PromisedAnswer{ QAId
answerId :: QAId
$sel:answerId:PromisedAnswer :: PromisedAnswer -> QAId
answerId } }) =
    Conn -> (Conn' -> STM ()) -> STM ()
whenLive Conn
conn ((Conn' -> STM ()) -> STM ()) -> (Conn' -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \Conn'
conn' ->
        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
            }
releaseTmpDest (RemoteDest (ImportDest Cell ImportRef
_)) = () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | 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] -> R.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 R.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?
    R.Return'exception Exception
exn ->
        TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Exception
exn
    R.Return'results R.Payload{ MPtr
content :: MPtr
$sel:content:Payload :: Payload -> MPtr
content } ->
        case [Word16] -> MPtr -> Either Exception MPtr
followPtrs [Word16]
transform MPtr
content of
            Right MPtr
v ->
                TmpDest -> (PromiseState -> STM ()) -> MPtr -> STM ()
resolveClientPtr TmpDest
tmpDest PromiseState -> STM ()
resolve MPtr
v
            Left Exception
e ->
                TmpDest -> (PromiseState -> STM ()) -> Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Exception
e

    Return'
R.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'
R.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."
            ]

    R.Return'takeFromOtherQuestion (Word32 -> QAId
QAId -> 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

    R.Return'acceptFromThirdParty MPtr
_ ->
        -- 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."

    R.Return'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 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)

-- | 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.get 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 sent 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.get 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.get 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'

-- | '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 a. a -> STM (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 -> STM () -> IO ()
forall a. Cell a -> STM () -> IO ()
Fin.addFinalizer Cell ImportRef
cell (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.get 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) =
        case PromisedAnswer -> Either Exception PromisedAnswer
unmarshalPromisedAnswer PromisedAnswer
pa of
            Left Exception
e ->
                Conn' -> Exception -> STM Client
forall a. Conn' -> Exception -> STM a
abortConn Conn'
conn' Exception
e
            Right PromisedAnswer
pa ->
                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 a. a -> STM (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 -> STM () -> IO ()
forall a. Cell a -> STM () -> IO ()
Fin.addFinalizer Cell ImportRef
cell (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.