{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module: Capnp.Rpc.Untyped
-- Description: Core of the RPC subsystem.
--
-- This module does not deal with schema-level concepts; all capabilities,
-- methods etc. as used here are untyped.
module Capnp.Rpc.Untyped
  ( -- * Connections to other vats
    ConnConfig (..),
    handleConn,

    -- * Clients for capabilities
    Client,
    call,
    nullClient,
    newPromiseClient,
    IsClient (..),

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

    -- * Exporting local objects
    export,
    clientMethodHandler,

    -- * Unwrapping local clients
    unwrapServer,

    -- * Waiting for resolution
    waitClient,

    -- * Errors
    RpcError (..),

    -- * Shutting down the connection
  )
where

import Capnp.Accessors
import qualified Capnp.Basics as B
import Capnp.Bits (WordCount, bytesToWordsFloor)
import Capnp.Classes (new, newRoot, parse)
import Capnp.Convert (msgToRaw, parsedToMsg)
import Capnp.Fields (Which)
import qualified Capnp.Gen.Capnp.Rpc as R
import Capnp.Message (Message)
import qualified Capnp.Message as Message
import Capnp.Mutability (Mutability (..), thaw)
import Capnp.Repr (Raw (..))
import Capnp.Rpc.Errors
  ( eDisconnected,
    eFailed,
    eMethodUnimplemented,
    eUnimplemented,
    wrapException,
  )
import Capnp.Rpc.Promise
  ( Fulfiller,
    Promise,
    breakOrFulfill,
    breakPromise,
    fulfill,
    newCallback,
    newPromise,
    newReadyPromise,
  )
import qualified Capnp.Rpc.Server as Server
import Capnp.Rpc.Transport (Transport (recvMsg, sendMsg))
import Capnp.TraversalLimit (LimitT, defaultLimit, evalLimitT)
import qualified Capnp.Untyped as UntypedRaw
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_, race_)
import Control.Concurrent.MVar (MVar, newEmptyMVar)
import Control.Concurrent.STM
import Control.Exception.Safe
  ( Exception,
    MonadThrow,
    SomeException,
    bracket,
    finally,
    fromException,
    throwIO,
    throwM,
    try,
  )
import Control.Monad (forever, join, void, when)
import Control.Monad.STM.Class
import Control.Monad.Trans.Class
import Data.Default (Default (def))
import Data.Dynamic (fromDynamic)
import Data.Foldable (for_, toList, traverse_)
import Data.Function ((&))
import Data.Hashable (Hashable, hash, hashWithSalt)
import Data.Maybe (catMaybes, fromMaybe)
import Data.String (fromString)
import Data.Text (Text)
import Data.Typeable (Typeable)
import qualified Data.Vector as V
import Data.Word
import qualified Focus
import GHC.Generics (Generic)
import Internal.BuildPure (createPure)
import Internal.Rc (Rc)
import qualified Internal.Rc as Rc
import Internal.Rpc.Breaker
import Internal.SnocList (SnocList)
import qualified Internal.SnocList as SnocList
import qualified Internal.TCloseQ as TCloseQ
import qualified Lifetimes.Gc as Fin
import qualified ListT
import qualified StmContainers.Map as M
import Supervisors (Supervisor, superviseSTM, withSupervisor)
import System.Mem.StableName (StableName, hashStableName, makeStableName)
import System.Timeout (timeout)

-- 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 'recvLoop') 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.

-- Note [Breaker]
-- ==============
--
-- Since capabilities can be stored in messages, it is somewhat challenging
-- to design a module structure that avoids low-level capnp serialization code
-- depending on the rpc system, simply because it needs to pass the 'Client'
-- type around, even if it doesn't do much else with it.
--
-- Earlier versions of this library capitulated and introduced a cyclic
-- dependency; there was a .hs-boot file for this module exposing 'Client'
-- and a couple other things, and "Capnp.Message" and a few other
-- serialization modules imported it.
--
-- This was a problem for a couple reasons:
--

-- * Not only was there a cyclic dependency, the path it took went through

--   a large fraction of the library, meaning whenever any of those modules
--   changes most of the library had to be rebuilt.

-- * It precluded doing things like splitting rpc support into a separate

--   package, for consumers who only want serialization and want a more
--   minimal dependency footprint.
--
-- Instead, the current solution is the "Internal.Rpc.Breaker" module; it
-- defines the few things needed by serialization code, but it does so
-- in a way that avoids depending on this module, sacrificing a small
-- amount of type safety by using "Data.Dynamic" instead of referencing
-- the types in this module directly. While in principle a caller could
-- supply some other type, we expect that:
--

-- * 'Client' will always wrap a @Maybe Client'@.

-- * 'Pipeline' will always wrap a @Pipeline'@.

--
-- we provide wrap/unwrap helper functions for each of these, to keep
-- the type-unsafety that comes with this as localized as possible.

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

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

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

instance Exception RpcError

newtype EmbargoId = EmbargoId {EmbargoId -> Word32
embargoWord :: Word32} deriving (EmbargoId -> EmbargoId -> Bool
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, Eq EmbargoId
Int -> EmbargoId -> Int
EmbargoId -> Int
forall a. Eq 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
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, Eq QAId
Int -> QAId -> Int
QAId -> Int
forall a. Eq 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
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, Eq IEId
Int -> IEId -> Int
IEId -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: IEId -> Int
$chash :: IEId -> Int
hashWithSalt :: Int -> IEId -> Int
$chashWithSalt :: Int -> IEId -> Int
Hashable)

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

instance Show IEId where
  show :: IEId -> [Char]
show = forall a. Show a => a -> [Char]
show 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' -> TChan (Message 'Const, Fulfiller ())
sendQ :: TChan (Message 'Const, Fulfiller ()),
    -- queue of messages to send sent to the remote vat; these are actually
    -- sent by a dedicated thread (see 'sendLoop').
    --
    -- The fulfiller is fulfilled after the message actually hits the transport.
    --
    -- The queue mainly exists for the sake of messages that are sent *while
    -- processing incomming messages*, since we cannot block in those cases,
    -- but it is used for all message sends to enforce ordering. The fulfiller
    -- is used by parts of the code (basically just calls) that want to block
    -- until their message is actually written to the socket.

    Conn' -> TVar WordCount
availableCallWords :: TVar WordCount,
    -- Semaphore used to limit the memory that can be used by in-progress
    -- calls originating from this connection. We don't just use a TSem
    -- because waitTSem doesn't let us wait for more than one token with a
    -- single call.

    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 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} = forall a. StableName a -> Int
hashStableName StableName (MVar ())
stableName
  hashWithSalt :: Int -> Conn -> Int
hashWithSalt Int
_ = forall a. Hashable a => a -> Int
hash

-- | Configuration information for a connection.
data ConnConfig = ConnConfig
  { -- | 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
maxQuestions :: !Word32,
    -- | The maximum number of objects which may be exported on this connection.
    --
    -- Defaults to 8192.
    ConnConfig -> Word32
maxExports :: !Word32,
    -- | The maximum total size of outstanding call messages that will be
    -- accepted; if this limit is reached, the implementation will not read
    -- more messages from the connection until some calls have completed
    -- and freed up enough space.
    --
    -- Defaults to 32MiB in words.
    ConnConfig -> WordCount
maxCallWords :: !WordCount,
    -- | 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 -> Bool
debugMode :: !Bool,
    -- | 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 -> Supervisor -> STM (Maybe Client)
getBootstrap :: Supervisor -> STM (Maybe Client),
    -- | 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.
    ConnConfig -> Maybe (Supervisor -> Client -> IO ())
withBootstrap :: Maybe (Supervisor -> Client -> IO ())
  }

instance Default ConnConfig where
  def :: ConnConfig
def =
    ConnConfig
      { $sel:maxQuestions:ConnConfig :: Word32
maxQuestions = Word32
128,
        $sel:maxExports:ConnConfig :: Word32
maxExports = Word32
8192,
        $sel:maxCallWords:ConnConfig :: WordCount
maxCallWords = ByteCount -> WordCount
bytesToWordsFloor forall a b. (a -> b) -> a -> b
$ ByteCount
32 forall a. Num a => a -> a -> a
* ByteCount
1024 forall a. Num a => a -> a -> a
* ByteCount
1024,
        $sel:debugMode:ConnConfig :: Bool
debugMode = Bool
False,
        $sel:getBootstrap:ConnConfig :: Supervisor -> STM (Maybe Client)
getBootstrap = \Supervisor
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing,
        $sel:withBootstrap:ConnConfig :: Maybe (Supervisor -> Client -> IO ())
withBootstrap = 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} = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM Conn'
conn SnocList (a -> STM ())
fs a
x = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> QAId
QAId forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdPool -> STM Word32
newId 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) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> IEId
IEId forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdPool -> STM Word32
newId 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) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> EmbargoId
EmbargoId forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdPool -> STM Word32
newId 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) 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,
      WordCount
maxCallWords :: WordCount
$sel:maxCallWords:ConnConfig :: ConnConfig -> WordCount
maxCallWords,
      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
    } =
    forall a. (Supervisor -> IO a) -> IO a
withSupervisor forall a b. (a -> b) -> a -> b
$ \Supervisor
sup ->
      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 <- forall a. a -> IO (StableName a)
makeStableName forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IO (MVar a)
newEmptyMVar
        forall a. STM a -> IO a
atomically 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

          TChan (Message 'Const, Fulfiller ())
sendQ <- forall a. STM (TChan a)
newTChan

          TVar WordCount
availableCallWords <- forall a. a -> STM (TVar a)
newTVar WordCount
maxCallWords

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

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

          let conn' :: Conn'
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,
                    TChan (Message 'Const, Fulfiller ())
sendQ :: TChan (Message 'Const, Fulfiller ())
$sel:sendQ:Conn' :: TChan (Message 'Const, Fulfiller ())
sendQ,
                    TVar WordCount
availableCallWords :: TVar WordCount
$sel:availableCallWords:Conn' :: TVar WordCount
availableCallWords,
                    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 <- forall a. a -> STM (TVar a)
newTVar (Conn' -> LiveState
Live Conn'
conn')
          let conn :: Conn
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
                  }
          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 <-
          forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$
            ( Transport -> Conn -> IO ()
recvLoop Transport
transport Conn
conn
                forall a b. IO a -> IO b -> IO ()
`concurrently_` Transport -> Conn' -> IO ()
sendLoop Transport
transport Conn'
conn'
                forall a b. IO a -> IO b -> IO ()
`concurrently_` Conn' -> IO ()
callbacksLoop Conn'
conn'
            )
              forall a b. IO a -> IO b -> IO ()
`race_` Conn -> Conn' -> IO ()
useBootstrap Conn
conn Conn'
conn'
        case Either RpcError ()
result of
          Left (SentAbort Parsed Exception
e) -> do
            -- We need to actually send it:
            Message 'Const
rawMsg <- forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure forall a. Bounded a => a
maxBound forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Message ('Mut s))
parsedToMsg forall a b. (a -> b) -> a -> b
$ Parsed Exception -> Parsed (Which Message)
R.Message'abort Parsed Exception
e
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Int -> IO a -> IO (Maybe a)
timeout Int
1000000 forall a b. (a -> b) -> a -> b
$ Transport -> Message 'Const -> IO ()
sendMsg Transport
transport Message 'Const
rawMsg
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Parsed Exception -> RpcError
SentAbort Parsed Exception
e
          Left RpcError
e ->
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO RpcError
e
          Right ()
_ ->
            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
          forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            let walk :: Map key value -> ((key, value) -> STM ()) -> STM ()
walk Map key value
table = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Monad m => (a -> m ()) -> ListT m a -> m ()
ListT.traverse_ (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 -> Maybe Client'
unwrapClient -> Just Client'
client') -> Conn -> Client' -> STM ()
dropConnExport Conn
conn Client'
client'
              Maybe Client
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            -- Remove everything from the exports table:
            forall {key} {value}.
Map key value -> ((key, value) -> STM ()) -> STM ()
walk Map IEId EntryE
exports 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:
            forall {key} {value}.
Map key value -> ((key, value) -> STM ()) -> STM ()
walk Map QAId EntryQA
questions forall a b. (a -> b) -> a -> b
$ \(QAId
qid, EntryQA
entry) ->
              let raiseDisconnected :: SnocList (Return -> STM ()) -> STM ()
raiseDisconnected SnocList (Return -> STM ())
onReturn =
                    forall a. Conn' -> SnocList (a -> STM ()) -> a -> STM ()
mapQueueSTM Conn'
conn' SnocList (Return -> STM ())
onReturn forall a b. (a -> b) -> a -> b
$
                      Return
                        { $sel:answerId:Return :: QAId
answerId = QAId
qid,
                          $sel:releaseParamCaps:Return :: Bool
releaseParamCaps = Bool
False,
                          $sel:union':Return :: Return'
union' = Parsed Exception -> Return'
Return'exception Parsed 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            -- same thing with embargos:
            forall {key} {value}.
Map key value -> ((key, value) -> STM ()) -> STM ()
walk Map EmbargoId (Fulfiller ())
embargos forall a b. (a -> b) -> a -> b
$ \(EmbargoId
_, Fulfiller ()
fulfiller) ->
              forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller ()
fulfiller Parsed Exception
eDisconnected
            -- mark the connection as dead, making the live state inaccessible:
            forall a. TVar a -> a -> STM ()
writeTVar TVar LiveState
liveState LiveState
Dead
      useBootstrap :: Conn -> Conn' -> IO ()
useBootstrap Conn
conn Conn'
conn' = case Maybe (Supervisor -> Client -> IO ())
withBootstrap of
        Maybe (Supervisor -> Client -> IO ())
Nothing ->
          forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay forall a. Bounded a => a
maxBound
        Just Supervisor -> Client -> IO ()
f ->
          forall a. STM a -> IO a
atomically (Conn -> STM Client
requestBootstrap Conn
conn) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> STM (TVar a)
newTVar [Word32
0 .. Word32
size 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) =
  forall a. TVar a -> STM a
readTVar TVar [Word32]
pool forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> forall a. STM a
retry
    (Word32
id : [Word32]
ids) -> do
      forall a. TVar a -> a -> STM ()
writeTVar TVar [Word32]
pool forall a b. (a -> b) -> a -> b
$! [Word32]
ids
      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 = forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Word32]
pool (Word32
id 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, one to invoke on each
    -- type of message.
    NewQA
      { EntryQA -> SnocList (Parsed Finish -> STM ())
onFinish :: SnocList (R.Parsed R.Finish -> STM ()),
        EntryQA -> SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
      }
  | -- | An entry for which we've sent/received a return, but not a finish.
    -- Contains the return message, and a set of callbacks to invoke on the
    -- finish.
    HaveReturn
      { EntryQA -> Return
returnMsg :: Return,
        onFinish :: SnocList (R.Parsed 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 -> Parsed Finish
finishMsg :: R.Parsed R.Finish,
        onReturn :: SnocList (Return -> STM ())
      }

-- | An entry in our imports table.
data EntryI = EntryI
  { -- | 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 -> Rc ()
localRc :: Rc (),
    -- | 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 -> Word32
remoteRc :: !Word32,
    -- | See Note [proxies]
    EntryI -> ExportMap
proxies :: ExportMap,
    -- | 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.
    EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState ::
      Maybe
        ( TVar PromiseState,
          TmpDest -- origTarget field. TODO(cleanup): clean this up a bit.
        )
  }

-- | An entry in our exports table.
data EntryE = EntryE
  { -- | 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 -> Client'
client :: Client',
    -- | The refcount for this entry. This lets us know when we can drop
    -- the entry from the table.
    EntryE -> Word32
refCount :: !Word32
  }

-- | 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 = forall a. a -> a
id
  fromClient :: Client -> Client
fromClient = forall a. a -> a
id

-- | See Note [Breaker]
wrapClient :: Maybe Client' -> Client
wrapClient :: Maybe Client' -> Client
wrapClient = Opaque -> Client
Client forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Typeable a, Eq a) => a -> Opaque
makeOpaque

-- | See Note [Breaker]
unwrapClient :: Client -> Maybe Client'
unwrapClient :: Client -> Maybe Client'
unwrapClient (Client Opaque
o) =
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => Dynamic -> Maybe a
fromDynamic forall a b. (a -> b) -> a -> b
$ Opaque -> Dynamic
reflectOpaque Opaque
o

data Client'
  = -- | A client pointing at a capability local to our own vat.
    LocalClient
      { -- | Record of what export IDs this client has on different remote
        -- connections.
        Client' -> ExportMap
exportMap :: ExportMap,
        -- | Queue a call for the local capability to handle. This is wrapped
        -- in a reference counted cell, whose finalizer stops the server.
        Client' -> Rc (CallInfo -> STM ())
qCall :: Rc (Server.CallInfo -> STM ()),
        -- | Finalizer key; when this is collected, qCall will be released.
        Client' -> Cell ()
finalizerKey :: Fin.Cell (),
        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
      { -- | The current state of the promise; the indirection allows
        -- the promise to be updated.
        Client' -> TVar PromiseState
pState :: TVar PromiseState,
        exportMap :: ExportMap,
        -- | 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.
        Client' -> TmpDest
origTarget :: TmpDest
      }
  | -- | A client which points to a (resolved) capability in a remote vat.
    ImportClient (Fin.Cell ImportRef)

data Pipeline' = Pipeline'
  { Pipeline' -> TVar PipelineState
state :: TVar PipelineState,
    Pipeline' -> SnocList Word16
steps :: SnocList Word16
  }
  deriving (Pipeline' -> Pipeline' -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pipeline' -> Pipeline' -> Bool
$c/= :: Pipeline' -> Pipeline' -> Bool
== :: Pipeline' -> Pipeline' -> Bool
$c== :: Pipeline' -> Pipeline' -> Bool
Eq)

-- | See Note [Breaker]
wrapPipeline :: Pipeline' -> Pipeline
wrapPipeline :: Pipeline' -> Pipeline
wrapPipeline = Opaque -> Pipeline
Pipeline forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Typeable a, Eq a) => a -> Opaque
makeOpaque

-- | See Note [Breaker]
unwrapPipeline :: Pipeline -> Pipeline'
unwrapPipeline :: Pipeline -> Pipeline'
unwrapPipeline (Pipeline Opaque
o) =
  case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Opaque -> Dynamic
reflectOpaque Opaque
o) of
    Maybe Pipeline'
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"invalid pipeline; dynamic unwrap failed"
    Just Pipeline'
p -> Pipeline'
p

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

-- | 'walkPipleinePtr' follows a pointer starting from the object referred to by the
-- 'Pipeline'. The 'Pipeline' must refer to a struct, and the pointer is referred to
-- by its index into the struct's pointer section.
walkPipelinePtr :: Pipeline -> Word16 -> Pipeline
walkPipelinePtr :: Pipeline -> Word16 -> Pipeline
walkPipelinePtr (Pipeline -> Pipeline'
unwrapPipeline -> p :: Pipeline'
p@Pipeline' {SnocList Word16
steps :: SnocList Word16
$sel:steps:Pipeline' :: Pipeline' -> SnocList Word16
steps}) Word16
step =
  Pipeline' -> Pipeline
wrapPipeline forall a b. (a -> b) -> a -> b
$ Pipeline'
p {$sel:steps:Pipeline' :: SnocList Word16
steps = 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 :: forall (m :: * -> *). MonadSTM m => Pipeline -> m Client
pipelineClient (Pipeline -> Pipeline'
unwrapPipeline -> 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}) = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ do
  forall a. TVar a -> STM a
readTVar TVar PipelineState
state 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 <- 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
$sel:answerId:PromisedAnswer :: QAId
answerId :: QAId
answerId, $sel:transform:PromisedAnswer :: SnocList Word16
transform = SnocList Word16
steps}
          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
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
client
        Just Client
client ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
client
    PendingLocalPipeline SnocList (Fulfiller RawMPtr)
subscribers -> do
      (Client
ret, Fulfiller Client
retFulfiller) <- forall (m :: * -> *) c.
(MonadSTM m, IsClient c) =>
m (c, Fulfiller c)
newPromiseClient
      Fulfiller RawMPtr
ptrFulfiller <- forall (m :: * -> *) a.
MonadSTM m =>
(Either (Parsed Exception) a -> STM ()) -> m (Fulfiller a)
newCallback forall a b. (a -> b) -> a -> b
$ \Either (Parsed Exception) RawMPtr
r -> do
        forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
state (Either (Parsed Exception) RawMPtr -> PipelineState
ReadyPipeline Either (Parsed Exception) RawMPtr
r)
        case Either (Parsed Exception) RawMPtr
r of
          Left Parsed Exception
e ->
            forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller Client
retFulfiller Parsed Exception
e
          Right RawMPtr
v ->
            (forall (m :: * -> *).
MonadThrow m =>
[Word16] -> RawMPtr -> m Client
ptrPathClient (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
steps) RawMPtr
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller Client
retFulfiller)
              forall e a. Exception e => STM a -> (e -> STM a) -> STM a
`catchSTM` (forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller Client
retFulfiller forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SomeException -> Parsed Exception
wrapException Bool
False)
      forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
state forall a b. (a -> b) -> a -> b
$ SnocList (Fulfiller RawMPtr) -> PipelineState
PendingLocalPipeline forall a b. (a -> b) -> a -> b
$ forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList (Fulfiller RawMPtr)
subscribers Fulfiller RawMPtr
ptrFulfiller
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
ret
    ReadyPipeline Either (Parsed Exception) RawMPtr
r -> do
      -- TODO(cleanup): factor out the commonalities between this and the above case.
      (Client
p, Fulfiller Client
f) <- forall (m :: * -> *) c.
(MonadSTM m, IsClient c) =>
m (c, Fulfiller c)
newPromiseClient
      case Either (Parsed Exception) RawMPtr
r of
        Left Parsed Exception
e -> forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller Client
f Parsed Exception
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
p
        Right RawMPtr
v ->
          forall (m :: * -> *).
MonadThrow m =>
[Word16] -> RawMPtr -> m Client
ptrPathClient (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
steps) RawMPtr
v
            forall e a. Exception e => STM a -> (e -> STM a) -> STM a
`catchSTM` ( \SomeException
e -> do
                           forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller Client
f (Bool -> SomeException -> Parsed Exception
wrapException Bool
False SomeException
e)
                           forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
p
                       )

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

promisedAnswerClient :: Conn -> PromisedAnswer -> STM Client
promisedAnswerClient :: Conn -> PromisedAnswer -> STM Client
promisedAnswerClient Conn
conn answer :: PromisedAnswer
answer@PromisedAnswer {QAId
answerId :: QAId
$sel:answerId:PromisedAnswer :: PromisedAnswer -> QAId
answerId, SnocList Word16
transform :: SnocList Word16
$sel:transform:PromisedAnswer :: PromisedAnswer -> SnocList Word16
transform} = do
  let tmpDest :: TmpDest
tmpDest = RemoteDest -> TmpDest
RemoteDest AnswerDest {Conn
$sel:conn:AnswerDest :: Conn
conn :: Conn
conn, PromisedAnswer
$sel:answer:AnswerDest :: PromisedAnswer
answer :: PromisedAnswer
answer}
  TVar PromiseState
pState <- forall a. a -> STM (TVar a)
newTVar Pending {TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest :: TmpDest
tmpDest}
  ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value. STM (Map key value)
M.new
  let client :: Client
client =
        Maybe Client' -> Client
wrapClient forall a b. (a -> b) -> a -> b
$
          forall a. a -> Maybe a
Just
            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
              }
  forall a. TVar a -> STM a
readTVar (Conn -> TVar LiveState
liveState Conn
conn) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LiveState
Dead ->
      TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest (forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) Parsed 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 forall a b. (a -> b) -> a -> b
$
        TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest (forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) Conn'
conn' (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
transform)
  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
      { -- | Capability to which the promise resolved.
        PromiseState -> Client
target :: Client
      }
  | -- | The promise has resolved, but is waiting on a Disembargo message
    -- before it is safe to send it messages.
    Embargo
      { -- | A queue in which to buffer calls while waiting for the
        -- disembargo.
        PromiseState -> TQueue CallInfo
callBuffer :: TQueue Server.CallInfo
      }
  | -- | The promise has not yet resolved.
    Pending
      { -- | A temporary destination to send calls, while we wait for the
        -- promise to resolve.
        PromiseState -> TmpDest
tmpDest :: TmpDest
      }
  | -- | The promise resolved to an exception.
    Error (R.Parsed 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
      { -- | The connection to the remote vat.
        RemoteDest -> Conn
conn :: Conn,
        -- | The answer to target.
        RemoteDest -> PromisedAnswer
answer :: PromisedAnswer
      }
  | -- | 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
  { -- | The connection to the remote vat.
    ImportRef -> Conn
conn :: Conn,
    -- | The import id for this capability.
    ImportRef -> IEId
importId :: !IEId,
    -- | Export ids to use when this client is passed to a vat other than
    -- the one identified by 'conn'. See Note [proxies]
    ImportRef -> ExportMap
proxies :: ExportMap
  }

-- 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 forall a. Eq a => a -> a -> Bool
== Conn
cy Bool -> Bool -> Bool
&& IEId
ix 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 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 forall a. Eq a => a -> a -> Bool
== TVar PromiseState
y
  ImportClient Cell ImportRef
x == ImportClient Cell ImportRef
y =
    Cell ImportRef
x forall a. Eq a => a -> a -> Bool
== Cell ImportRef
y
  Client'
_ == Client'
_ =
    Bool
False

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

-- The below correspond to the similarly named types in
-- rpc.capnp, except:
--

-- * They use our newtype wrappers for ids

-- * They don't have unknown variants

-- * AnyPointers are left un-parsed

-- * PromisedAnswer's transform field is just a list of pointer offsets,

--   rather than a union with no other actually-useful variants.

-- * PromisedAnswer's transform field is a SnocList, for efficient appending.

data MsgTarget
  = ImportTgt !IEId
  | AnswerTgt PromisedAnswer

data PromisedAnswer = PromisedAnswer
  { PromisedAnswer -> QAId
answerId :: !QAId,
    PromisedAnswer -> SnocList Word16
transform :: SnocList Word16
  }

data Call = Call
  { Call -> QAId
questionId :: !QAId,
    Call -> MsgTarget
target :: !MsgTarget,
    Call -> Word64
interfaceId :: !Word64,
    Call -> Word16
methodId :: !Word16,
    Call -> Payload
params :: !Payload
  }

data Return = Return
  { Return -> QAId
answerId :: !QAId,
    Return -> Bool
releaseParamCaps :: !Bool,
    Return -> Return'
union' :: Return'
  }

data Return'
  = Return'results Payload
  | Return'exception (R.Parsed R.Exception)
  | Return'canceled
  | Return'resultsSentElsewhere
  | Return'takeFromOtherQuestion QAId
  | Return'acceptFromThirdParty RawMPtr

data Payload = Payload
  { Payload -> RawMPtr
content :: RawMPtr,
    Payload -> Vector (Parsed CapDescriptor)
capTable :: V.Vector (R.Parsed R.CapDescriptor)
  }

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

-- | Queue a call on a client.
call :: MonadSTM m => Server.CallInfo -> Client -> m (Promise Pipeline)
call :: forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m (Promise Pipeline)
call Server.CallInfo {Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response} (Client -> Maybe Client'
unwrapClient -> Maybe Client'
Nothing) = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response Parsed Exception
eMethodUnimplemented
  TVar PipelineState
state <- forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$ Either (Parsed Exception) RawMPtr -> PipelineState
ReadyPipeline (forall a b. a -> Either a b
Left Parsed Exception
eMethodUnimplemented)
  forall (m :: * -> *) a. MonadSTM m => a -> m (Promise a)
newReadyPromise forall a b. (a -> b) -> a -> b
$ Pipeline' -> Pipeline
wrapPipeline Pipeline' {TVar PipelineState
state :: TVar PipelineState
$sel:state:Pipeline' :: TVar PipelineState
state, $sel:steps:Pipeline' :: SnocList Word16
steps = forall a. Monoid a => a
mempty}
call info :: CallInfo
info@Server.CallInfo {Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response} (Client -> Maybe Client'
unwrapClient -> Just Client'
client') = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ do
  (Pipeline
localPipeline, Fulfiller RawMPtr
response') <- Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr)
makeLocalPipeline Fulfiller RawMPtr
response
  let info' :: CallInfo
info' = CallInfo
info {response :: Fulfiller RawMPtr
Server.response = Fulfiller RawMPtr
response'}
  case Client'
client' of
    LocalClient {Rc (CallInfo -> STM ())
qCall :: Rc (CallInfo -> STM ())
$sel:qCall:LocalClient :: Client' -> Rc (CallInfo -> STM ())
qCall} -> do
      forall a. Rc a -> STM (Maybe a)
Rc.get Rc (CallInfo -> STM ())
qCall 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 ->
          forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response' Parsed Exception
eDisconnected
      forall (m :: * -> *) a. MonadSTM m => a -> m (Promise a)
newReadyPromise Pipeline
localPipeline
    PromiseClient {TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: Client' -> TVar PromiseState
pState} ->
      forall a. TVar a -> STM a
readTVar TVar PromiseState
pState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Ready {Client
target :: Client
$sel:target:Ready :: PromiseState -> Client
target} ->
          forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m (Promise Pipeline)
call CallInfo
info Client
target
        Embargo {TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:Ready :: PromiseState -> TQueue CallInfo
callBuffer} -> do
          forall a. TQueue a -> a -> STM ()
writeTQueue TQueue CallInfo
callBuffer CallInfo
info'
          forall (m :: * -> *) a. MonadSTM m => a -> m (Promise a)
newReadyPromise 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
            forall a. TQueue a -> a -> STM ()
writeTQueue TQueue CallInfo
callBuffer CallInfo
info'
            forall (m :: * -> *) a. MonadSTM m => a -> m (Promise a)
newReadyPromise 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 (Promise Pipeline)
callRemote Conn
conn CallInfo
info 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} <- forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
            Conn -> CallInfo -> MsgTarget -> STM (Promise Pipeline)
callRemote Conn
conn CallInfo
info forall a b. (a -> b) -> a -> b
$ IEId -> MsgTarget
ImportTgt IEId
importId
        Error Parsed Exception
exn -> do
          forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response' Parsed Exception
exn
          forall (m :: * -> *) a. MonadSTM m => a -> m (Promise a)
newReadyPromise 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} <- forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
      Conn -> CallInfo -> MsgTarget -> STM (Promise Pipeline)
callRemote Conn
conn CallInfo
info (IEId -> MsgTarget
ImportTgt IEId
importId)

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

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

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

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

    forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
      NewQA
        { $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn = forall a. a -> SnocList a
SnocList.singleton forall a b. (a -> b) -> a -> b
$ [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM ()
cbCallReturn [IEId]
paramCaps Conn
conn Fulfiller RawMPtr
response',
          $sel:onFinish:NewQA :: SnocList (Parsed Finish -> STM ())
onFinish = forall a. SnocList a
SnocList.empty
        }
      QAId
qid
      Map QAId EntryQA
questions
    (Promise Pipeline
p, Fulfiller Pipeline
f) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
    Fulfiller ()
f <- forall (m :: * -> *) a.
MonadSTM m =>
(Either (Parsed Exception) a -> STM ()) -> m (Fulfiller a)
newCallback forall a b. (a -> b) -> a -> b
$ \Either (Parsed Exception) ()
r ->
      forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either (Parsed Exception) a -> m ()
breakOrFulfill Fulfiller Pipeline
f (Pipeline' -> Pipeline
wrapPipeline Pipeline' {$sel:state:Pipeline' :: TVar PipelineState
state = TVar PipelineState
rp, $sel:steps:Pipeline' :: SnocList Word16
steps = forall a. Monoid a => a
mempty} forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Either (Parsed Exception) ()
r)
    Conn' -> Call -> Fulfiller () -> STM ()
sendCall
      Conn'
conn'
      Call
        { $sel:questionId:Call :: QAId
questionId = QAId
qid,
          $sel:target:Call :: MsgTarget
target = MsgTarget
target,
          $sel:params:Call :: Payload
params = Payload
payload,
          Word64
interfaceId :: Word64
$sel:interfaceId:Call :: Word64
interfaceId,
          Word16
methodId :: Word16
$sel:methodId:Call :: Word16
methodId
        }
      Fulfiller ()
f
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Promise Pipeline
p

-- | Callback to run when a return comes in that corresponds to a call
-- we sent. Registered in callRemote. The first argument is a list of
-- export IDs to release if the return message has releaseParamCaps = true.
cbCallReturn :: [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM ()
cbCallReturn :: [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM ()
cbCallReturn
  [IEId]
paramCaps
  Conn
conn
  Fulfiller RawMPtr
response
  Return {QAId
answerId :: QAId
$sel:answerId:Return :: Return -> QAId
answerId, Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union', Bool
releaseParamCaps :: Bool
$sel:releaseParamCaps:Return :: Return -> Bool
releaseParamCaps} = do
    conn' :: Conn'
conn'@Conn' {Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} <- Conn -> STM Conn'
getLive Conn
conn
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
releaseParamCaps forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Word32
1) [IEId]
paramCaps
    case Return'
union' of
      Return'exception Parsed Exception
exn ->
        forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response Parsed Exception
exn
      Return'results Payload {RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content} ->
        forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller RawMPtr
response RawMPtr
content
      Return'
Return'canceled ->
        forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed Text
"Canceled"
      Return'
Return'resultsSentElsewhere ->
        -- This should never happen, since we always set
        -- sendResultsTo = caller
        forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
          Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
            forall a. Monoid a => [a] -> a
mconcat
              [ Text
"Received Return.resultsSentElswhere for a call ",
                Text
"with sendResultsTo = caller."
              ]
      Return'takeFromOtherQuestion QAId
qid ->
        -- TODO(cleanup): we should be a little stricter; the protocol
        -- requires that (1) each answer is only used this way once, and
        -- (2) The question was sent with sendResultsTo set to 'yourself',
        -- but we don't enforce either of these requirements.
        Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"answer" Conn'
conn' Map QAId EntryQA
answers QAId
qid forall a b. (a -> b) -> a -> b
$
          [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM ()
cbCallReturn [] Conn
conn Fulfiller RawMPtr
response
      Return'acceptFromThirdParty RawMPtr
_ ->
        -- Note [Level 3]
        forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
          Text -> Parsed Exception
eUnimplemented
            Text
"This vat does not support level 3."
    -- Defer this until after any other callbacks run, in case disembargos
    -- need to be sent due to promise resolutions that we triggered:
    Conn' -> STM () -> STM ()
queueSTM Conn'
conn' forall a b. (a -> b) -> a -> b
$
      Conn' -> Parsed Finish -> STM ()
finishQuestion
        Conn'
conn'
        forall a. Default a => a
def
          { $sel:questionId:Finish :: Parsed Word32
R.questionId = QAId -> Word32
qaWord QAId
answerId,
            $sel:releaseResultCaps:Finish :: Parsed Bool
R.releaseResultCaps = Bool
False
          }

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

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

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

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

-- | 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 :: forall (m :: * -> *) c.
(MonadSTM m, IsClient c) =>
m (c, Fulfiller c)
newPromiseClient = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ do
  TQueue CallInfo
callBuffer <- forall a. STM (TQueue a)
newTQueue
  let tmpDest :: TmpDest
tmpDest = LocalDest -> TmpDest
LocalDest LocalBuffer {TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: TQueue CallInfo
callBuffer}
  TVar PromiseState
pState <- forall a. a -> STM (TVar a)
newTVar Pending {TmpDest
tmpDest :: TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest}
  ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value. STM (Map key value)
M.new
  Fulfiller c
f <- forall (m :: * -> *) a.
MonadSTM m =>
(Either (Parsed Exception) a -> STM ()) -> m (Fulfiller a)
newCallback forall a b. (a -> b) -> a -> b
$ \case
    Left Parsed Exception
e -> TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest (forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) Parsed Exception
e
    Right c
v -> TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest (forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) (forall a. IsClient a => a -> Client
toClient c
v)
  let p :: Client
p =
        Maybe Client' -> Client
wrapClient forall a b. (a -> b) -> a -> b
$
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            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
              }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall c a. (IsClient c, Typeable a) => c -> Maybe a
unwrapServer c
c = case Client -> Maybe Client'
unwrapClient (forall a. IsClient a => a -> Client
toClient c
c) of
  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} -> forall a. Typeable a => Maybe a
unwrapper
  Maybe Client'
_ -> 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 :: forall c (m :: * -> *). (IsClient c, MonadSTM m) => c -> m c
waitClient c
client = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ case Client -> Maybe Client'
unwrapClient (forall a. IsClient a => a -> Client
toClient c
client) of
  Maybe Client'
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure c
client
  Just LocalClient {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure c
client
  Just ImportClient {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure c
client
  Just PromiseClient {TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: Client' -> TVar PromiseState
pState} -> do
    PromiseState
state <- forall a. TVar a -> STM a
readTVar TVar PromiseState
pState
    case PromiseState
state of
      Ready {Client
target :: Client
$sel:target:Ready :: PromiseState -> Client
target} -> forall a. IsClient a => Client -> a
fromClient forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c (m :: * -> *). (IsClient c, MonadSTM m) => c -> m c
waitClient Client
target
      Error Parsed Exception
e -> forall e a. Exception e => e -> STM a
throwSTM Parsed Exception
e
      Pending {} -> forall a. STM a
retry
      Embargo {} -> 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 -> m Client
export :: forall (m :: * -> *).
MonadSTM m =>
Supervisor -> ServerOps -> m Client
export Supervisor
sup ServerOps
ops = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ do
  Q CallInfo
q <- forall a. STM (Q a)
TCloseQ.new
  Rc (CallInfo -> STM ())
qCall <- forall a. a -> STM () -> STM (Rc a)
Rc.new (forall a. Q a -> a -> STM ()
TCloseQ.write Q CallInfo
q) (forall a. Q a -> STM ()
TCloseQ.close Q CallInfo
q)
  ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value. STM (Map key value)
M.new
  Cell ()
finalizerKey <- forall (m :: * -> *) a. MonadSTM m => a -> m (Cell a)
Fin.newCell ()
  let client' :: Client'
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 -> forall a. Typeable a => Maybe a
Server.handleCast ServerOps
ops
          }
  Supervisor -> IO () -> STM ()
superviseSTM
    Supervisor
sup
    ( ( do
          forall a. Cell a -> IO () -> IO ()
Fin.addFinalizer Cell ()
finalizerKey forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. Rc a -> STM ()
Rc.release Rc (CallInfo -> STM ())
qCall
          Q CallInfo -> ServerOps -> IO ()
Server.runServer Q CallInfo
q ServerOps
ops
      )
        forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` ServerOps -> IO ()
Server.handleStop ServerOps
ops
    )
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
wrapClient (forall a. a -> Maybe a
Just Client'
client')

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

-- | See Note [callbacks]
callbacksLoop :: Conn' -> IO ()
callbacksLoop :: Conn' -> IO ()
callbacksLoop Conn' {TQueue (IO ())
pendingCallbacks :: TQueue (IO ())
$sel:pendingCallbacks:Conn' :: Conn' -> TQueue (IO ())
pendingCallbacks} =
  IO ()
loop forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` IO ()
cleanup
  where
    loop :: IO ()
loop =
      forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
        forall {m :: * -> *} {t :: * -> *}.
(MonadMask m, Foldable t) =>
m (t (m ())) -> m ()
doCallbacks forall a b. (a -> b) -> a -> b
$
          forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
            forall a. TQueue a -> STM [a]
flushTQueue TQueue (IO ())
pendingCallbacks 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.
              [] -> forall a. STM a
retry
              [IO ()]
cbs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [IO ()]
cbs
    cleanup :: IO ()
cleanup =
      -- Make sure any pending callbacks get run. This is important, since
      -- some of these do things like raise disconnected exceptions.
      forall {m :: * -> *} {t :: * -> *}.
(MonadMask m, Foldable t) =>
m (t (m ())) -> m ()
doCallbacks forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> STM [a]
flushTQueue TQueue (IO ())
pendingCallbacks
    doCallbacks :: m (t (m ())) -> m ()
doCallbacks m (t (m ()))
getCbs =
      -- We need to be careful not to lose any callbacks in the event
      -- of an exception (even an async one):
      forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
        m (t (m ()))
getCbs
        (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
        (\t (m ())
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | 'sendLoop' shunts messages from the send queue into the transport.
sendLoop :: Transport -> Conn' -> IO ()
sendLoop :: Transport -> Conn' -> IO ()
sendLoop Transport
transport Conn' {TChan (Message 'Const, Fulfiller ())
sendQ :: TChan (Message 'Const, Fulfiller ())
$sel:sendQ:Conn' :: Conn' -> TChan (Message 'Const, Fulfiller ())
sendQ} =
  forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    (Message 'Const
msg, Fulfiller ()
f) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan TChan (Message 'Const, Fulfiller ())
sendQ
    Transport -> Message 'Const -> IO ()
sendMsg Transport
transport Message 'Const
msg
    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller ()
f ()

-- | 'recvLoop' processes incoming messages.
recvLoop :: Transport -> 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.
recvLoop :: Transport -> Conn -> IO ()
recvLoop Transport
transport conn :: Conn
conn@Conn {Bool
debugMode :: Bool
$sel:debugMode:Conn :: Conn -> Bool
debugMode} = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
  Message 'Const
capnpMsg <- Transport -> IO (Message 'Const)
recvMsg Transport
transport
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e a. Exception e => STM a -> (e -> STM a) -> STM a
catchSTM (forall e a. Exception e => e -> STM a
throwSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SomeException -> RpcError
makeAbortExn Bool
debugMode) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit forall a b. (a -> b) -> a -> b
$ do
        Raw Message 'Const
rpcMsg <- forall a (m :: * -> *) (mut :: Mutability).
(ReadCtx m mut, IsStruct a) =>
Message mut -> m (Raw a mut)
msgToRaw Message 'Const
capnpMsg
        RawWhich Message 'Const
which <- forall a (mut :: Mutability) (m :: * -> *).
(ReadCtx m mut, HasUnion a) =>
Raw a mut -> m (RawWhich a mut)
structWhich Raw Message 'Const
rpcMsg
        case RawWhich Message 'Const
which of
          R.RW_Message'abort Raw Exception 'Const
exn ->
            forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Exception 'Const
exn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Parsed Exception -> STM ()
handleAbortMsg Conn
conn
          R.RW_Message'unimplemented Raw Message 'Const
oldMsg ->
            forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Message 'Const
oldMsg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Parsed Message -> STM ()
handleUnimplementedMsg Conn
conn
          R.RW_Message'bootstrap Raw Bootstrap 'Const
bs ->
            forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Bootstrap 'Const
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Parsed Bootstrap -> STM ()
handleBootstrapMsg Conn
conn
          R.RW_Message'call Raw Call 'Const
call -> do
            Conn -> Raw Call 'Const -> LimitT STM ()
handleCallMsg Conn
conn Raw Call 'Const
call
          R.RW_Message'return Raw Return 'Const
ret -> do
            Return
ret' <- Conn -> Raw Return 'Const -> LimitT STM Return
acceptReturn Conn
conn Raw Return 'Const
ret
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Conn -> Return -> STM ()
handleReturnMsg Conn
conn Return
ret'
          R.RW_Message'finish Raw Finish 'Const
finish ->
            forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Finish 'Const
finish forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Parsed Finish -> STM ()
handleFinishMsg Conn
conn
          R.RW_Message'resolve Raw Resolve 'Const
res ->
            forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Resolve 'Const
res forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Parsed Resolve -> STM ()
handleResolveMsg Conn
conn
          R.RW_Message'release Raw Release 'Const
release ->
            forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Release 'Const
release forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Parsed Release -> STM ()
handleReleaseMsg Conn
conn
          R.RW_Message'disembargo Raw Disembargo 'Const
disembargo ->
            forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Disembargo 'Const
disembargo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> Parsed Disembargo -> STM ()
handleDisembargoMsg Conn
conn
          RawWhich Message 'Const
_ -> do
            Parsed Message
msg <- forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Message 'Const
rpcMsg
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
              (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
              Conn'
conn' <- Conn -> STM Conn'
getLive Conn
conn
              Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg Conn'
conn' (Parsed Message -> Parsed (Which Message)
R.Message'unimplemented Parsed Message
msg) Fulfiller ()
onSent

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

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

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

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

handleCallMsg :: Conn -> Raw R.Call 'Const -> LimitT STM ()
handleCallMsg :: Conn -> Raw Call 'Const -> LimitT STM ()
handleCallMsg Conn
conn Raw Call 'Const
callMsg = do
  conn' :: Conn'
conn'@Conn' {Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports, Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers, TVar WordCount
availableCallWords :: TVar WordCount
$sel:availableCallWords:Conn' :: Conn' -> TVar WordCount
availableCallWords} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Conn -> STM Conn'
getLive Conn
conn
  let capnpMsg :: Message 'Const
capnpMsg = forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
UntypedRaw.message @(Raw R.Call) Raw Call 'Const
callMsg

  -- Apply backpressure, by limiting the memory usage of outstanding call
  -- messages.
  WordCount
msgWords <- forall (mut :: Mutability) (m :: * -> *).
MonadReadMessage mut m =>
Message mut -> m WordCount
Message.totalNumWords Message 'Const
capnpMsg
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
    WordCount
available <- forall a. TVar a -> STM a
readTVar TVar WordCount
availableCallWords
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (WordCount
msgWords forall a. Ord a => a -> a -> Bool
> WordCount
available)
      forall a. STM a
retry
    forall a. TVar a -> a -> STM ()
writeTVar TVar WordCount
availableCallWords forall a b. (a -> b) -> a -> b
$! WordCount
available forall a. Num a => a -> a -> a
- WordCount
msgWords

  Word32
questionId <- forall a b bp (m :: * -> *) (k :: FieldKind).
(IsStruct a, Parse b bp, ReadCtx m 'Const) =>
Field k a b -> Raw a 'Const -> m bp
parseField forall a. IsLabel "questionId" a => a
#questionId Raw Call 'Const
callMsg
  R.MessageTarget Parsed (Which MessageTarget)
target <- forall a b bp (m :: * -> *) (k :: FieldKind).
(IsStruct a, Parse b bp, ReadCtx m 'Const) =>
Field k a b -> Raw a 'Const -> m bp
parseField forall a. IsLabel "target" a => a
#target Raw Call 'Const
callMsg
  Word64
interfaceId <- forall a b bp (m :: * -> *) (k :: FieldKind).
(IsStruct a, Parse b bp, ReadCtx m 'Const) =>
Field k a b -> Raw a 'Const -> m bp
parseField forall a. IsLabel "interfaceId" a => a
#interfaceId Raw Call 'Const
callMsg
  Word16
methodId <- forall a b bp (m :: * -> *) (k :: FieldKind).
(IsStruct a, Parse b bp, ReadCtx m 'Const) =>
Field k a b -> Raw a 'Const -> m bp
parseField forall a. IsLabel "methodId" a => a
#methodId Raw Call 'Const
callMsg
  Raw Payload 'Const
payload <- forall (k :: FieldKind) a b (mut :: Mutability) (m :: * -> *).
(IsStruct a, ReadCtx m mut) =>
Field k a b -> Raw a mut -> m (Raw b mut)
readField forall a. IsLabel "params" a => a
#params Raw Call 'Const
callMsg

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

  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
    -- First, add an entry in our answers table:
    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
        { $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn =
            forall a. [a] -> SnocList a
SnocList.fromList
              [ \Return
_ ->
                  forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar WordCount
availableCallWords (WordCount
msgWords forall a. Num a => a -> a -> a
+)
              ],
          $sel:onFinish:NewQA :: SnocList (Parsed Finish -> STM ())
onFinish =
            forall a. [a] -> SnocList a
SnocList.fromList
              [ \R.Finish {Parsed Bool
releaseResultCaps :: Parsed Bool
$sel:releaseResultCaps:Finish :: Parsed Finish -> Parsed Bool
releaseResultCaps} ->
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Parsed Bool
releaseResultCaps forall a b. (a -> b) -> a -> b
$
                    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Vector (Parsed CapDescriptor)
capTable forall a b. (a -> b) -> a -> b
$ \R.CapDescriptor {Parsed (Which CapDescriptor)
union' :: Parsed (Which CapDescriptor)
$sel:union':CapDescriptor :: Parsed CapDescriptor -> Parsed (Which CapDescriptor)
union'} -> case Parsed (Which CapDescriptor)
union' of
                      R.CapDescriptor'receiverHosted (Word32 -> IEId
IEId -> IEId
importId) ->
                        Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Word32
1 IEId
importId
                      Parsed (Which CapDescriptor)
_ ->
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              ]
        }
      Map QAId EntryQA
answers

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

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

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

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

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

sendRawMsg :: Conn' -> Message 'Const -> Fulfiller () -> STM ()
sendRawMsg :: Conn' -> Message 'Const -> Fulfiller () -> STM ()
sendRawMsg Conn'
conn' Message 'Const
msg Fulfiller ()
onSent = forall a. TChan a -> a -> STM ()
writeTChan (Conn' -> TChan (Message 'Const, Fulfiller ())
sendQ Conn'
conn') (Message 'Const
msg, Fulfiller ()
onSent)

sendCall :: Conn' -> Call -> Fulfiller () -> STM ()
sendCall :: Conn' -> Call -> Fulfiller () -> STM ()
sendCall
  Conn'
conn'
  Call {QAId
questionId :: QAId
$sel:questionId:Call :: Call -> QAId
questionId, MsgTarget
target :: MsgTarget
$sel:target:Call :: Call -> MsgTarget
target, Word64
interfaceId :: Word64
$sel:interfaceId:Call :: Call -> Word64
interfaceId, Word16
methodId :: Word16
$sel:methodId:Call :: Call -> Word16
methodId, $sel:params:Call :: Call -> Payload
params = Payload {RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content, Vector (Parsed CapDescriptor)
capTable :: Vector (Parsed CapDescriptor)
$sel:capTable:Payload :: Payload -> Vector (Parsed CapDescriptor)
capTable}}
  Fulfiller ()
onSent = do
    Message 'Const
msg <- forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure WordCount
defaultLimit forall a b. (a -> b) -> a -> b
$ do
      Maybe (Ptr ('Mut s))
mcontent <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
thaw RawMPtr
content
      Message ('Mut s)
msg <- case Maybe (Ptr ('Mut s))
mcontent of
        Just Ptr ('Mut s)
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
UntypedRaw.message @UntypedRaw.Ptr Ptr ('Mut s)
v
        Maybe (Ptr ('Mut s))
Nothing -> forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
Message.newMessage forall a. Maybe a
Nothing
      Raw Payload ('Mut s)
payload <- forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
new @R.Payload () Message ('Mut s)
msg
      Raw Payload ('Mut s)
payload forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s.
(IsStruct a, RWCtx m s) =>
Field 'Slot a b -> Raw b ('Mut s) -> Raw a ('Mut s) -> m ()
setField forall a. IsLabel "content" a => a
#content (forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
Raw Maybe (Ptr ('Mut s))
mcontent)
      Raw Payload ('Mut s)
payload forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "capTable" a => a
#capTable Vector (Parsed CapDescriptor)
capTable
      Raw Call ('Mut s)
call <- forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
new @R.Call () Message ('Mut s)
msg
      forall a b (m :: * -> *) s.
(IsStruct a, RWCtx m s) =>
Field 'Slot a b -> Raw b ('Mut s) -> Raw a ('Mut s) -> m ()
setField forall a. IsLabel "params" a => a
#params Raw Payload ('Mut s)
payload Raw Call ('Mut s)
call
      Raw Call ('Mut s)
call forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "questionId" a => a
#questionId (QAId -> Word32
qaWord QAId
questionId)
      Raw Call ('Mut s)
call forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "interfaceId" a => a
#interfaceId Word64
interfaceId
      Raw Call ('Mut s)
call forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "methodId" a => a
#methodId Word16
methodId
      Raw Call ('Mut s)
call forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "target" a => a
#target (MsgTarget -> Parsed MessageTarget
marshalMsgTarget MsgTarget
target)
      Raw Message ('Mut s)
rpcMsg <- forall a (m :: * -> *) s.
(RWCtx m s, IsStruct a, Allocate a) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
newRoot @R.Message () Message ('Mut s)
msg
      forall a b (m :: * -> *) s.
(HasUnion a, RWCtx m s) =>
Variant 'Slot a b -> Raw a ('Mut s) -> Raw b ('Mut s) -> m ()
setVariant forall a. IsLabel "call" a => a
#call Raw Message ('Mut s)
rpcMsg Raw Call ('Mut s)
call
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Message ('Mut s)
msg
    Conn' -> Message 'Const -> Fulfiller () -> STM ()
sendRawMsg Conn'
conn' Message 'Const
msg Fulfiller ()
onSent

sendReturn :: Conn' -> Return -> STM ()
sendReturn :: Conn' -> Return -> STM ()
sendReturn Conn'
conn' Return {QAId
answerId :: QAId
$sel:answerId:Return :: Return -> QAId
answerId, Bool
releaseParamCaps :: Bool
$sel:releaseParamCaps:Return :: Return -> Bool
releaseParamCaps, Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union'} = do
  (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
  case Return'
union' of
    Return'results Payload {RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content, Vector (Parsed CapDescriptor)
capTable :: Vector (Parsed CapDescriptor)
$sel:capTable:Payload :: Payload -> Vector (Parsed CapDescriptor)
capTable} -> do
      Message 'Const
msg <- forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure WordCount
defaultLimit forall a b. (a -> b) -> a -> b
$ do
        Maybe (Ptr ('Mut s))
mcontent <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
thaw RawMPtr
content
        Message ('Mut s)
msg <- case Maybe (Ptr ('Mut s))
mcontent of
          Just Ptr ('Mut s)
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
UntypedRaw.message @UntypedRaw.Ptr Ptr ('Mut s)
v
          Maybe (Ptr ('Mut s))
Nothing -> forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
Message.newMessage forall a. Maybe a
Nothing
        Raw Payload ('Mut s)
payload <- forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
new @R.Payload () Message ('Mut s)
msg
        Raw Payload ('Mut s)
payload forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s.
(IsStruct a, RWCtx m s) =>
Field 'Slot a b -> Raw b ('Mut s) -> Raw a ('Mut s) -> m ()
setField forall a. IsLabel "content" a => a
#content (forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
Raw Maybe (Ptr ('Mut s))
mcontent)
        Raw Payload ('Mut s)
payload forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "capTable" a => a
#capTable Vector (Parsed CapDescriptor)
capTable
        Raw Return ('Mut s)
ret <- forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
new @R.Return () Message ('Mut s)
msg
        forall a b (m :: * -> *) s.
(HasUnion a, RWCtx m s) =>
Variant 'Slot a b -> Raw a ('Mut s) -> Raw b ('Mut s) -> m ()
setVariant forall a. IsLabel "results" a => a
#results Raw Return ('Mut s)
ret Raw Payload ('Mut s)
payload
        Raw Return ('Mut s)
ret forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "answerId" a => a
#answerId (QAId -> Word32
qaWord QAId
answerId)
        Raw Return ('Mut s)
ret forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "releaseParamCaps" a => a
#releaseParamCaps Bool
releaseParamCaps
        Raw Message ('Mut s)
rpcMsg <- forall a (m :: * -> *) s.
(RWCtx m s, IsStruct a, Allocate a) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
newRoot @R.Message () Message ('Mut s)
msg
        forall a b (m :: * -> *) s.
(HasUnion a, RWCtx m s) =>
Variant 'Slot a b -> Raw a ('Mut s) -> Raw b ('Mut s) -> m ()
setVariant forall a. IsLabel "return" a => a
#return Raw Message ('Mut s)
rpcMsg Raw Return ('Mut s)
ret
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Message ('Mut s)
msg
      Conn' -> Message 'Const -> Fulfiller () -> STM ()
sendRawMsg Conn'
conn' Message 'Const
msg Fulfiller ()
onSent
    Return'exception Parsed Exception
exn ->
      Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
        Conn'
conn'
        ( Parsed Return -> Parsed (Which Message)
R.Message'return
            R.Return
              { $sel:answerId:Return :: Parsed Word32
answerId = QAId -> Word32
qaWord QAId
answerId,
                Bool
$sel:releaseParamCaps:Return :: Parsed Bool
releaseParamCaps :: Bool
releaseParamCaps,
                $sel:union':Return :: Parsed (Which Return)
union' = Parsed Exception -> Parsed (Which Return)
R.Return'exception Parsed Exception
exn
              }
        )
        Fulfiller ()
onSent
    Return'
Return'canceled ->
      Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
        Conn'
conn'
        ( Parsed Return -> Parsed (Which Message)
R.Message'return
            R.Return
              { $sel:answerId:Return :: Parsed Word32
answerId = QAId -> Word32
qaWord QAId
answerId,
                Bool
$sel:releaseParamCaps:Return :: Parsed Bool
releaseParamCaps :: Bool
releaseParamCaps,
                $sel:union':Return :: Parsed (Which Return)
union' = Parsed (Which Return)
R.Return'canceled
              }
        )
        Fulfiller ()
onSent
    Return'
Return'resultsSentElsewhere ->
      Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
        Conn'
conn'
        ( Parsed Return -> Parsed (Which Message)
R.Message'return
            R.Return
              { $sel:answerId:Return :: Parsed Word32
answerId = QAId -> Word32
qaWord QAId
answerId,
                Bool
$sel:releaseParamCaps:Return :: Parsed Bool
releaseParamCaps :: Bool
releaseParamCaps,
                $sel:union':Return :: Parsed (Which Return)
union' = Parsed (Which Return)
R.Return'resultsSentElsewhere
              }
        )
        Fulfiller ()
onSent
    Return'takeFromOtherQuestion (QAId Word32
qid) ->
      Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
        Conn'
conn'
        ( Parsed Return -> Parsed (Which Message)
R.Message'return
            R.Return
              { $sel:answerId:Return :: Parsed Word32
answerId = QAId -> Word32
qaWord QAId
answerId,
                Bool
$sel:releaseParamCaps:Return :: Parsed Bool
releaseParamCaps :: Bool
releaseParamCaps,
                $sel:union':Return :: Parsed (Which Return)
union' = Parsed Word32 -> Parsed (Which Return)
R.Return'takeFromOtherQuestion Word32
qid
              }
        )
        Fulfiller ()
onSent
    Return'acceptFromThirdParty RawMPtr
ptr -> do
      Message 'Const
msg <- forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure WordCount
defaultLimit forall a b. (a -> b) -> a -> b
$ do
        Maybe (Ptr ('Mut s))
mptr <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Mutability -> *) (m :: * -> *) s.
(MaybeMutable f, PrimMonad m, PrimState m ~ s) =>
f 'Const -> m (f ('Mut s))
thaw RawMPtr
ptr
        Message ('Mut s)
msg <- case Maybe (Ptr ('Mut s))
mptr of
          Just Ptr ('Mut s)
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
UntypedRaw.message @UntypedRaw.Ptr Ptr ('Mut s)
v
          Maybe (Ptr ('Mut s))
Nothing -> forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
Message.newMessage forall a. Maybe a
Nothing
        Raw Return ('Mut s)
ret <- forall a (m :: * -> *) s.
(Allocate a, RWCtx m s) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
new @R.Return () Message ('Mut s)
msg
        Raw Return ('Mut s)
ret forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "answerId" a => a
#answerId (QAId -> Word32
qaWord QAId
answerId)
        Raw Return ('Mut s)
ret forall a b. a -> (a -> b) -> b
& forall a b (m :: * -> *) s bp.
(IsStruct a, Parse b bp, RWCtx m s) =>
Field 'Slot a b -> bp -> Raw a ('Mut s) -> m ()
encodeField forall a. IsLabel "releaseParamCaps" a => a
#releaseParamCaps Bool
releaseParamCaps
        forall a b (m :: * -> *) s.
(HasUnion a, RWCtx m s) =>
Variant 'Slot a b -> Raw a ('Mut s) -> Raw b ('Mut s) -> m ()
setVariant forall a. IsLabel "acceptFromThirdParty" a => a
#acceptFromThirdParty Raw Return ('Mut s)
ret (forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
Raw @(Maybe B.AnyPointer) Maybe (Ptr ('Mut s))
mptr)
        Raw Message ('Mut s)
rpcMsg <- forall a (m :: * -> *) s.
(RWCtx m s, IsStruct a, Allocate a) =>
AllocHint a -> Message ('Mut s) -> m (Raw a ('Mut s))
newRoot @R.Message () Message ('Mut s)
msg
        forall a b (m :: * -> *) s.
(HasUnion a, RWCtx m s) =>
Variant 'Slot a b -> Raw a ('Mut s) -> Raw b ('Mut s) -> m ()
setVariant forall a. IsLabel "return" a => a
#return Raw Message ('Mut s)
rpcMsg Raw Return ('Mut s)
ret
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Message ('Mut s)
msg
      Conn' -> Message 'Const -> Fulfiller () -> STM ()
sendRawMsg Conn'
conn' Message 'Const
msg Fulfiller ()
onSent

acceptReturn :: Conn -> Raw R.Return 'Const -> LimitT STM Return
acceptReturn :: Conn -> Raw Return 'Const -> LimitT STM Return
acceptReturn Conn
conn Raw Return 'Const
ret = do
  let answerId :: QAId
answerId = Word32 -> QAId
QAId (forall a b (sz :: DataSz) bp.
(IsStruct a, ReprFor b ~ 'Data sz, Parse b bp) =>
Field 'Slot a b -> Raw a 'Const -> bp
getField forall a. IsLabel "answerId" a => a
#answerId Raw Return 'Const
ret)
      releaseParamCaps :: Bool
releaseParamCaps = forall a b (sz :: DataSz) bp.
(IsStruct a, ReprFor b ~ 'Data sz, Parse b bp) =>
Field 'Slot a b -> Raw a 'Const -> bp
getField forall a. IsLabel "releaseParamCaps" a => a
#releaseParamCaps Raw Return 'Const
ret
  RawWhich Return 'Const
which <- forall a (mut :: Mutability) (m :: * -> *).
(ReadCtx m mut, HasUnion a) =>
Raw a mut -> m (RawWhich a mut)
structWhich Raw Return 'Const
ret
  Return'
union' <- case RawWhich Return 'Const
which of
    R.RW_Return'results Raw Payload 'Const
payload ->
      Payload -> Return'
Return'results forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conn -> Raw Payload 'Const -> LimitT STM Payload
acceptPayload Conn
conn Raw Payload 'Const
payload
    R.RW_Return'exception Raw Exception 'Const
exn ->
      Parsed Exception -> Return'
Return'exception forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Exception 'Const
exn
    R.RW_Return'canceled Raw () 'Const
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Return'
Return'canceled
    R.RW_Return'resultsSentElsewhere Raw () 'Const
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Return'
Return'resultsSentElsewhere
    R.RW_Return'takeFromOtherQuestion Raw Word32 'Const
id ->
      QAId -> Return'
Return'takeFromOtherQuestion forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> QAId
QAId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
parse Raw Word32 'Const
id
    R.RW_Return'acceptFromThirdParty (Raw Unwrapped (Untyped (ReprFor (Maybe AnyPointer)) 'Const)
ptr) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawMPtr -> Return'
Return'acceptFromThirdParty Unwrapped (Untyped (ReprFor (Maybe AnyPointer)) 'Const)
ptr
    R.RW_Return'unknown' Word16
ordinal ->
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> STM a
throwSTM forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$ Text
"Unknown return variant #" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Word16
ordinal)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Return {QAId
answerId :: QAId
$sel:answerId:Return :: QAId
answerId, Bool
releaseParamCaps :: Bool
$sel:releaseParamCaps:Return :: Bool
releaseParamCaps, Return'
union' :: Return'
$sel:union':Return :: Return'
union'}

handleReturnMsg :: Conn -> Return -> STM ()
handleReturnMsg :: Conn -> Return -> STM ()
handleReturnMsg Conn
conn Return
ret =
  Conn -> STM Conn'
getLive Conn
conn 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.Parsed R.Finish -> STM ()
handleFinishMsg :: Conn -> Parsed Finish -> STM ()
handleFinishMsg Conn
conn Parsed Finish
finish =
  Conn -> STM Conn'
getLive Conn
conn 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 -> Parsed Finish -> STM ()
updateQAFinish Conn'
conn' Map QAId EntryQA
answers Text
"answer" Parsed Finish
finish

handleResolveMsg :: Conn -> R.Parsed R.Resolve -> STM ()
handleResolveMsg :: Conn -> Parsed Resolve -> STM ()
handleResolveMsg Conn
conn R.Resolve {Parsed Word32
$sel:promiseId:Resolve :: Parsed Resolve -> Parsed Word32
promiseId :: Parsed Word32
promiseId, Parsed (Which Resolve)
$sel:union':Resolve :: Parsed Resolve -> Parsed (Which Resolve)
union' :: Parsed (Which Resolve)
union'} =
  Conn -> STM Conn'
getLive Conn
conn 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 <- forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup (Word32 -> IEId
IEId Parsed 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 Parsed (Which Resolve)
union' of
          R.Resolve'cap R.CapDescriptor {$sel:union':CapDescriptor :: Parsed CapDescriptor -> Parsed (Which CapDescriptor)
union' = R.CapDescriptor'receiverHosted Parsed Word32
importId} -> do
            (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
            -- Send a release message for the resolved cap, since
            -- we're not going to use it:
            Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
              Conn'
conn'
              ( Parsed Release -> Parsed (Which Message)
R.Message'release
                  forall a. Default a => a
def
                    { $sel:id:Release :: Parsed Word32
R.id = Parsed Word32
importId,
                      $sel:referenceCount:Release :: Parsed Word32
R.referenceCount = Word32
1
                    }
              )
              Fulfiller ()
onSent
          -- Note [Level 3]: do we need to do something with
          -- thirdPartyHosted here?
          Parsed (Which Resolve)
_ -> 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.
        forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
          Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
            forall a. Monoid a => [a] -> a
mconcat
              [ Text
"Received a resolve message for export id #",
                forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Parsed 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 Parsed (Which Resolve)
union' of
          R.Resolve'cap R.CapDescriptor {$sel:union':CapDescriptor :: Parsed CapDescriptor -> Parsed (Which CapDescriptor)
union' = Parsed (Which CapDescriptor)
cap} -> do
            Client
client <- Conn -> Parsed (Which CapDescriptor) -> STM Client
acceptCap Conn
conn Parsed (Which CapDescriptor)
cap
            TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest (forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
tvar) Client
client
          R.Resolve'exception Parsed Exception
exn ->
            TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest (forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
tvar) Parsed Exception
exn
          R.Resolve'unknown' Word16
tag ->
            forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
              Text -> Parsed Exception
eUnimplemented forall a b. (a -> b) -> a -> b
$
                forall a. Monoid a => [a] -> a
mconcat
                  [ Text
"Resolve variant #",
                    forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Word16
tag),
                    Text
" not understood"
                  ]

handleReleaseMsg :: Conn -> R.Parsed R.Release -> STM ()
handleReleaseMsg :: Conn -> Parsed Release -> STM ()
handleReleaseMsg
  Conn
conn
  R.Release
    { $sel:id:Release :: Parsed Release -> Parsed Word32
id = (Word32 -> IEId
IEId -> IEId
eid),
      $sel:referenceCount:Release :: Parsed Release -> Parsed Word32
referenceCount = Parsed Word32
refCountDiff
    } =
    Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Parsed 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 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} ->
    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 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 forall a. Ord a => a -> a -> Ordering
compare Word32
oldRefCount Word32
refCountDiff of
          Ordering
LT ->
            forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
              Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
                Text
"Received release for export with referenceCount "
                  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 ->
            forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
              EntryE
                { Client'
client :: Client'
$sel:client:EntryE :: Client'
client,
                  $sel:refCount:EntryE :: Word32
refCount = Word32
oldRefCount forall a. Num a => a -> a -> a
- Word32
refCountDiff
                }
              IEId
eid
              Map IEId EntryE
exports

handleDisembargoMsg :: Conn -> R.Parsed R.Disembargo -> STM ()
handleDisembargoMsg :: Conn -> Parsed Disembargo -> STM ()
handleDisembargoMsg Conn
conn Parsed Disembargo
d = Conn -> STM Conn'
getLive Conn
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parsed Disembargo -> Conn' -> STM ()
go Parsed Disembargo
d
  where
    go :: Parsed Disembargo -> Conn' -> STM ()
go
      R.Disembargo
        { $sel:context:Disembargo :: Parsed Disembargo -> Parsed Disembargo'context
context =
            R.Disembargo'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 <- 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 ->
              forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
                Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
                  Text
"No such embargo: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ EmbargoId -> Word32
embargoWord EmbargoId
eid)
            Just Fulfiller ()
fulfiller -> do
              Conn' -> STM () -> STM ()
queueSTM Conn'
conn' (forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller ()
fulfiller ())
              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
        { $sel:target:Disembargo :: Parsed Disembargo -> Parsed MessageTarget
target = R.MessageTarget Parsed (Which MessageTarget)
target,
          $sel:context:Disembargo :: Parsed Disembargo -> Parsed Disembargo'context
context = R.Disembargo'context' (R.Disembargo'context'senderLoopback Parsed 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 Parsed (Which MessageTarget)
target of
          R.MessageTarget'importedCap Parsed Word32
exportId ->
            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 Parsed Word32
exportId) 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 {Parsed Word32
questionId :: Parsed Word32
$sel:questionId:PromisedAnswer :: Parsed PromisedAnswer -> Parsed Word32
questionId, Parsed (List PromisedAnswer'Op)
transform :: Parsed (List PromisedAnswer'Op)
$sel:transform:PromisedAnswer :: Parsed PromisedAnswer -> Parsed (List PromisedAnswer'Op)
transform} ->
            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 Parsed Word32
questionId) forall a b. (a -> b) -> a -> b
$ \case
              HaveReturn {$sel:returnMsg:NewQA :: EntryQA -> Return
returnMsg = Return {$sel:union':Return :: Return -> Return'
union' = Return'results Payload {RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content}}} ->
                Vector (Parsed PromisedAnswer'Op) -> RawMPtr -> Conn' -> STM Client
transformClient Parsed (List PromisedAnswer'Op)
transform RawMPtr
content Conn'
conn' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  (Client -> Maybe Client'
unwrapClient -> Just Client'
client') -> Client' -> STM ()
disembargoClient Client'
client'
                  (Client -> Maybe Client'
unwrapClient -> Maybe Client'
Nothing) -> Text -> STM ()
abortDisembargo Text
"targets a null capability"
              EntryQA
_ ->
                Text -> STM ()
abortDisembargo forall a b. (a -> b) -> a -> b
$
                  Text
"does not target an answer which has resolved to a value hosted by"
                    forall a. Semigroup a => a -> a -> a
<> Text
" the sender."
          R.MessageTarget'unknown' Word16
ordinal ->
            forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
              Text -> Parsed Exception
eUnimplemented forall a b. (a -> b) -> a -> b
$
                Text
"Unknown MessageTarget ordinal #" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Word16
ordinal)
        where
          disembargoPromise :: Client' -> STM ()
disembargoPromise PromiseClient {TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: Client' -> TVar PromiseState
pState} =
            forall a. TVar a -> STM a
readTVar TVar PromiseState
pState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Ready (Client -> Maybe Client'
unwrapClient -> Just Client'
client) ->
                Client' -> STM ()
disembargoClient Client'
client
              Ready (Client -> Maybe Client'
unwrapClient -> 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 <- forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
            case ImportRef
client of
              ImportRef {$sel:conn:ImportRef :: ImportRef -> Conn
conn = Conn
targetConn, IEId
importId :: IEId
$sel:importId:ImportRef :: ImportRef -> IEId
importId}
                | Conn
conn forall a. Eq a => a -> a -> Bool
== Conn
targetConn -> do
                    (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
                    Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
                      Conn'
conn'
                      ( Parsed Disembargo -> Parsed (Which Message)
R.Message'disembargo
                          R.Disembargo
                            { $sel:context:Disembargo :: Parsed Disembargo'context
context =
                                Parsed (Which Disembargo'context) -> Parsed Disembargo'context
R.Disembargo'context' forall a b. (a -> b) -> a -> b
$
                                  Parsed Word32 -> Parsed (Which Disembargo'context)
R.Disembargo'context'receiverLoopback Parsed Word32
embargoId,
                              $sel:target:Disembargo :: Parsed MessageTarget
target =
                                Parsed (Which MessageTarget) -> Parsed MessageTarget
R.MessageTarget forall a b. (a -> b) -> a -> b
$
                                  Parsed Word32 -> Parsed (Which MessageTarget)
R.MessageTarget'importedCap (IEId -> Word32
ieWord IEId
importId)
                            }
                      )
                      Fulfiller ()
onSent
              ImportRef
_ ->
                STM ()
abortDisembargoClient
          disembargoClient Client'
_ = STM ()
abortDisembargoClient

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

          abortDisembargo :: Text -> STM ()
abortDisembargo Text
info =
            forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
              Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
                forall a. Monoid a => [a] -> a
mconcat
                  [ Text
"Disembargo #",
                    forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Parsed Word32
embargoId),
                    Text
" with context = senderLoopback ",
                    Text
info
                  ]
    -- Note [Level 3]
    go Parsed Disembargo
d Conn'
conn' = do
      (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
      Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
        Conn'
conn'
        (Parsed Message -> Parsed (Which Message)
R.Message'unimplemented forall a b. (a -> b) -> a -> b
$ Parsed (Which Message) -> Parsed Message
R.Message forall a b. (a -> b) -> a -> b
$ Parsed Disembargo -> Parsed (Which Message)
R.Message'disembargo Parsed Disembargo
d)
        Fulfiller ()
onSent

lookupAbort ::
  (Eq k, Hashable k, Show k) =>
  Text ->
  Conn' ->
  M.Map k v ->
  k ->
  (v -> STM a) ->
  STM a
lookupAbort :: forall k v a.
(Eq k, Hashable k, Show k) =>
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 <- 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 ->
      forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn forall a b. (a -> b) -> a -> b
$
        Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
          forall a. Monoid a => [a] -> a
mconcat
            [ Text
"No such ",
              Text
keyTypeName,
              Text
": ",
              forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
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 :: forall k v.
(Eq k, Hashable k) =>
Text -> Conn' -> k -> v -> Map k v -> STM ()
insertNewAbort Text
keyTypeName Conn'
conn k
key v
value =
  forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
M.focus
    ( forall (m :: * -> *) a.
Monad m =>
(Maybe a -> m (Maybe a)) -> Focus a m ()
Focus.alterM forall a b. (a -> b) -> a -> b
$ \case
        Just v
_ ->
          forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn forall a b. (a -> b) -> a -> b
$
            Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
              Text
"duplicate entry in " forall a. Semigroup a => a -> a -> a
<> Text
keyTypeName forall a. Semigroup a => a -> a -> a
<> Text
" table."
        Maybe v
Nothing ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just v
value)
    )
    k
key

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

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

sendPureMsg :: Conn' -> R.Parsed (Which R.Message) -> Fulfiller () -> STM ()
sendPureMsg :: Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg Conn' {TChan (Message 'Const, Fulfiller ())
sendQ :: TChan (Message 'Const, Fulfiller ())
$sel:sendQ:Conn' :: Conn' -> TChan (Message 'Const, Fulfiller ())
sendQ} Parsed (Which Message)
msg Fulfiller ()
onSent = do
  Message 'Const
msg <- forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure forall a. Bounded a => a
maxBound (forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Message ('Mut s))
parsedToMsg (Parsed (Which Message) -> Parsed Message
R.Message Parsed (Which Message)
msg))
  forall a. TChan a -> a -> STM ()
writeTChan TChan (Message 'Const, Fulfiller ())
sendQ (Message 'Const
msg, Fulfiller ()
onSent)

-- | Send a finish message, updating connection state and triggering
-- callbacks as necessary.
finishQuestion :: Conn' -> R.Parsed R.Finish -> STM ()
finishQuestion :: Conn' -> Parsed Finish -> STM ()
finishQuestion conn :: Conn'
conn@Conn' {Map QAId EntryQA
questions :: Map QAId EntryQA
$sel:questions:Conn' :: Conn' -> Map QAId EntryQA
questions} finish :: Parsed Finish
finish@R.Finish {Parsed Word32
questionId :: Parsed Word32
$sel:questionId:Finish :: Parsed Finish -> Parsed 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 Parsed Word32
questionId) forall a b. (a -> b) -> a -> b
$ \Return
_ ->
    Conn' -> QAId -> STM ()
freeQuestion Conn'
conn (Word32 -> QAId
QAId Parsed Word32
questionId)
  (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
  Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg Conn'
conn (Parsed Finish -> Parsed (Which Message)
R.Message'finish Parsed Finish
finish) Fulfiller ()
onSent
  Conn' -> Map QAId EntryQA -> Text -> Parsed Finish -> STM ()
updateQAFinish Conn'
conn Map QAId EntryQA
questions Text
"question" Parsed Finish
finish

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

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

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

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

-- | Update an entry in the questions or answers table to queue the given
-- callback when the return message for that answer comes in. If the return
-- has already arrived, the callback is queued immediately.
--
-- If the entry already has other callbacks registered, this callback is
-- run *after* the others (see Note [callbacks]). Note that this is an
-- important property, as it is necessary to preserve E-order if the
-- callbacks are successive method calls on the returned object.
subscribeReturn :: Text -> Conn' -> M.Map QAId EntryQA -> QAId -> (Return -> STM ()) -> STM ()
subscribeReturn :: Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
tableName Conn'
conn Map QAId EntryQA
table QAId
qaId Return -> STM ()
onRet =
  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 forall a b. (a -> b) -> a -> b
$ \EntryQA
qa -> do
    EntryQA
new <- EntryQA -> STM EntryQA
go EntryQA
qa
    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 (Parsed Finish -> STM ())
onFinish :: SnocList (Parsed Finish -> STM ())
$sel:onFinish:NewQA :: EntryQA -> SnocList (Parsed Finish -> STM ())
onFinish, SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          NewQA
            { SnocList (Parsed Finish -> STM ())
onFinish :: SnocList (Parsed Finish -> STM ())
$sel:onFinish:NewQA :: SnocList (Parsed Finish -> STM ())
onFinish,
              $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn = forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList (Return -> STM ())
onReturn Return -> STM ()
onRet
            }
      HaveFinish {Parsed Finish
finishMsg :: Parsed Finish
$sel:finishMsg:NewQA :: EntryQA -> Parsed Finish
finishMsg, SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          HaveFinish
            { Parsed Finish
finishMsg :: Parsed Finish
$sel:finishMsg:NewQA :: Parsed Finish
finishMsg,
              $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn = 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
        Return -> STM ()
onRet Return
returnMsg
        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 receieve loop or the callback loop.
abortConn :: Conn' -> R.Parsed R.Exception -> STM a
abortConn :: forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
_ Parsed Exception
e = forall e a. Exception e => e -> STM a
throwSTM (Parsed Exception -> RpcError
SentAbort Parsed 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} =
  forall a. TVar a -> STM a
readTVar TVar LiveState
liveState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Live Conn'
conn' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Conn'
conn'
    LiveState
Dead -> forall e a. Exception e => e -> STM a
throwSTM Parsed 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 =
  forall a. TVar a -> STM a
readTVar TVar LiveState
liveState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Live Conn'
conn' -> Conn' -> STM ()
f Conn'
conn'
    LiveState
Dead -> 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} =
  forall a. TVar a -> STM a
readTVar TVar LiveState
liveState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LiveState
Dead ->
      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
conn :: Conn
$sel:conn:AnswerDest :: Conn
conn,
                  $sel:answer:AnswerDest :: PromisedAnswer
answer =
                    PromisedAnswer
                      { $sel:answerId:PromisedAnswer :: QAId
answerId = QAId
qid,
                        $sel:transform:PromisedAnswer :: SnocList Word16
transform = forall a. SnocList a
SnocList.empty
                      }
                }
      TVar PromiseState
pState <- forall a. a -> STM (TVar a)
newTVar Pending {TmpDest
tmpDest :: TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest}

      -- Arguably, we should wait for this promise, since it's analagous
      -- to a call in terms of operation, but we only send one of these
      -- per connection, so whatever.
      (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
      Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
        Conn'
conn'
        (Parsed Bootstrap -> Parsed (Which Message)
R.Message'bootstrap (forall a. Default a => a
def {$sel:questionId:Bootstrap :: Parsed Word32
R.questionId = QAId -> Word32
qaWord QAId
qid} :: R.Parsed R.Bootstrap))
        Fulfiller ()
onSent

      forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
        NewQA
          { $sel:onReturn:NewQA :: SnocList (Return -> STM ())
onReturn =
              forall a. [a] -> SnocList a
SnocList.fromList
                [ TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest (forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState) Conn'
conn' [],
                  \Return
_ ->
                    Conn' -> Parsed Finish -> STM ()
finishQuestion
                      Conn'
conn'
                      R.Finish
                        { $sel:questionId:Finish :: Parsed Word32
questionId = QAId -> Word32
qaWord QAId
qid,
                          $sel:releaseResultCaps:Finish :: Parsed Bool
releaseResultCaps = Bool
False
                        }
                ],
            $sel:onFinish:NewQA :: SnocList (Parsed Finish -> STM ())
onFinish = forall a. SnocList a
SnocList.empty
          }
        QAId
qid
        Map QAId EntryQA
questions
      ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value. STM (Map key value)
M.new
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        Maybe Client' -> Client
wrapClient forall a b. (a -> b) -> a -> b
$
          forall a. a -> Maybe a
Just
            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.Parsed R.Exception -> STM ()
resolveClientExn :: TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Parsed Exception
exn = do
  case TmpDest
tmpDest of
    LocalDest LocalBuffer {TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: LocalDest -> TQueue CallInfo
callBuffer} -> do
      [CallInfo]
calls <- forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
        ( \Server.CallInfo {Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response} ->
            forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response Parsed Exception
exn
        )
        [CallInfo]
calls
    RemoteDest AnswerDest {} ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    RemoteDest (ImportDest Cell ImportRef
_) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  PromiseState -> STM ()
resolve forall a b. (a -> b) -> a -> b
$ Parsed Exception -> PromiseState
Error Parsed Exception
exn

-- Resolve a promised client to a pointer. If it is a non-null non-capability
-- pointer, it resolves to an exception. See Note [resolveClient]
resolveClientPtr :: TmpDest -> (PromiseState -> STM ()) -> RawMPtr -> STM ()
resolveClientPtr :: TmpDest -> (PromiseState -> STM ()) -> RawMPtr -> STM ()
resolveClientPtr TmpDest
tmpDest PromiseState -> STM ()
resolve RawMPtr
ptr = case RawMPtr
ptr of
  RawMPtr
Nothing ->
    TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest PromiseState -> STM ()
resolve Client
nullClient
  Just (UntypedRaw.PtrCap Cap 'Const
c) -> do
    Client
c' <- forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
UntypedRaw.getClient Cap 'Const
c
    TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest PromiseState -> STM ()
resolve Client
c'
  Just Ptr 'Const
_ ->
    TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve forall a b. (a -> b) -> a -> b
$
      Text -> Parsed 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'
unwrapClient -> 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
_) ->
      -- If it resolves to a null client, then we can't send a disembargo.
      -- Note that this may result in futrther calls throwing exceptions
      -- /before/ the outstanding calls, which is a bit weird. But all
      -- calls will throw at some point, so it's probably fine.
      STM ()
resolveNow
    -- 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 forall a. Eq a => a -> a -> Bool
== Conn
oldConn
        then STM ()
resolveNow
        else RemoteDest -> STM ()
disembargoAndResolve RemoteDest
oldDest
    (Just (ImportClient Cell ImportRef
cell), RemoteDest RemoteDest
oldDest) -> do
      ImportRef {$sel:conn:ImportRef :: ImportRef -> Conn
conn = Conn
newConn} <- forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
      Conn
oldConn <- RemoteDest -> STM Conn
destConn RemoteDest
oldDest
      if Conn
newConn forall a. Eq a => a -> a -> Bool
== Conn
oldConn
        then STM ()
resolveNow
        else RemoteDest -> STM ()
disembargoAndResolve RemoteDest
oldDest
  where
    destConn :: RemoteDest -> STM Conn
destConn AnswerDest {Conn
conn :: Conn
$sel:conn:AnswerDest :: RemoteDest -> Conn
conn} = 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} <- forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
      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} = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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} <- forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ IEId -> MsgTarget
ImportTgt IEId
importId

    resolveNow :: STM ()
resolveNow = do
      PromiseState -> STM ()
resolve forall a b. (a -> b) -> a -> b
$ Client -> PromiseState
Ready (Maybe Client' -> Client
wrapClient 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
      forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m (Promise Pipeline)
`call` Maybe Client' -> Client
wrapClient Maybe Client'
client)
      PromiseState -> STM ()
resolve forall a b. (a -> b) -> a -> b
$ Client -> PromiseState
Ready (Maybe Client' -> Client
wrapClient Maybe Client'
client)
    flushAndRaise :: TQueue CallInfo -> Parsed Exception -> STM ()
flushAndRaise TQueue CallInfo
callBuffer Parsed Exception
e =
      forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Server.CallInfo {Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response} -> forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response Parsed 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
      forall a. TVar a -> STM a
readTVar TVar LiveState
liveState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Live Conn'
conn' -> do
          TQueue CallInfo
callBuffer <- forall a. STM (TQueue a)
newTQueue
          MsgTarget
target <- RemoteDest -> STM MsgTarget
destTarget RemoteDest
dest
          Conn'
-> MsgTarget -> (Either (Parsed Exception) () -> STM ()) -> STM ()
disembargo Conn'
conn' MsgTarget
target forall a b. (a -> b) -> a -> b
$ \case
            Right () ->
              TQueue CallInfo -> STM ()
flushAndResolve TQueue CallInfo
callBuffer
            Left Parsed Exception
e ->
              TQueue CallInfo -> Parsed Exception -> STM ()
flushAndRaise TQueue CallInfo
callBuffer Parsed Exception
e
          PromiseState -> STM ()
resolve forall a b. (a -> b) -> a -> b
$ Embargo {TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:Ready :: TQueue CallInfo
callBuffer}
        LiveState
Dead ->
          TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Parsed 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.Parsed R.Exception) () -> STM ()) -> STM ()
disembargo :: Conn'
-> MsgTarget -> (Either (Parsed 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 (Parsed Exception) () -> STM ()
onEcho = do
  Fulfiller ()
callback <- forall (m :: * -> *) a.
MonadSTM m =>
(Either (Parsed Exception) a -> STM ()) -> m (Fulfiller a)
newCallback Either (Parsed Exception) () -> STM ()
onEcho
  EmbargoId
eid <- Conn' -> STM EmbargoId
newEmbargo Conn'
conn
  forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert Fulfiller ()
callback EmbargoId
eid Map EmbargoId (Fulfiller ())
embargos
  (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
  Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
    Conn'
conn
    ( Parsed Disembargo -> Parsed (Which Message)
R.Message'disembargo
        R.Disembargo
          { $sel:target:Disembargo :: Parsed MessageTarget
target = MsgTarget -> Parsed MessageTarget
marshalMsgTarget MsgTarget
tgt,
            $sel:context:Disembargo :: Parsed Disembargo'context
context =
              Parsed (Which Disembargo'context) -> Parsed Disembargo'context
R.Disembargo'context' forall a b. (a -> b) -> a -> b
$
                Parsed Word32 -> Parsed (Which Disembargo'context)
R.Disembargo'context'senderLoopback (EmbargoId -> Word32
embargoWord EmbargoId
eid)
          }
    )
    Fulfiller ()
onSent

-- | Resolve a promised client to the result of a return. See Note [resolveClient]
--
-- The [Word16] is a list of pointer indexes to follow from the result.
resolveClientReturn :: TmpDest -> (PromiseState -> STM ()) -> Conn' -> [Word16] -> Return -> STM ()
resolveClientReturn :: TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest PromiseState -> STM ()
resolve conn :: Conn'
conn@Conn' {Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} [Word16]
transform Return {Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union'} = case Return'
union' of
  -- TODO(cleanup) there is a lot of redundency betwen this and cbCallReturn; can
  -- we refactor?
  Return'exception Parsed Exception
exn ->
    TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Parsed Exception
exn
  Return'results Payload {RawMPtr
content :: RawMPtr
$sel:content:Payload :: Payload -> RawMPtr
content} -> do
    Either (Parsed Exception) RawMPtr
res <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
ReadCtx m 'Const =>
[Word16] -> RawMPtr -> m RawMPtr
followPtrs [Word16]
transform RawMPtr
content
    case Either (Parsed Exception) RawMPtr
res of
      Right RawMPtr
v ->
        TmpDest -> (PromiseState -> STM ()) -> RawMPtr -> STM ()
resolveClientPtr TmpDest
tmpDest PromiseState -> STM ()
resolve RawMPtr
v
      Left Parsed Exception
e ->
        TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve Parsed Exception
e
  Return'
Return'canceled ->
    TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed Text
"Canceled"
  Return'
Return'resultsSentElsewhere ->
    -- Should never happen; we don't set sendResultsTo to anything other than
    -- caller.
    forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn forall a b. (a -> b) -> a -> b
$
      Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
        forall a. Monoid a => [a] -> a
mconcat
          [ Text
"Received Return.resultsSentElsewhere for a call ",
            Text
"with sendResultsTo = caller."
          ]
  Return'takeFromOtherQuestion QAId
qid ->
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"answer" Conn'
conn Map QAId EntryQA
answers QAId
qid forall a b. (a -> b) -> a -> b
$
      TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest PromiseState -> STM ()
resolve Conn'
conn [Word16]
transform
  Return'acceptFromThirdParty RawMPtr
_ ->
    -- Note [Level 3]
    forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn forall a b. (a -> b) -> a -> b
$
      Text -> Parsed Exception
eUnimplemented
        Text
"This vat does not support level 3."

-- | Get the client's export ID for this connection, or allocate a new one if needed.
-- If this is the first time this client has been exported on this connection,
-- bump the refcount.
getConnExport :: Conn -> Client' -> STM IEId
getConnExport :: Conn -> Client' -> STM IEId
getConnExport Conn
conn Client'
client =
  Conn -> STM Conn'
getLive Conn
conn 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 <- 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
        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
        forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert IEId
eid Conn
conn Map Conn IEId
m
        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 <- 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
      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 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
        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 ->
      forall a. HasCallStack => [Char] -> a
error [Char]
"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} = forall (f :: * -> *) a. Applicative f => a -> f a
pure ExportMap
exportMap
clientExportMap PromiseClient {ExportMap
exportMap :: ExportMap
$sel:exportMap:LocalClient :: Client' -> ExportMap
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} <- forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
  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 =
  forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
M.focus (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 = forall a. a -> Maybe a
Just 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 forall a. Eq a => a -> a -> Bool
/= Client'
oldClient =
          forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
            [Char]
"BUG: addExportRef called with a client that is different "
              forall a. [a] -> [a] -> [a]
++ [Char]
"from what is already in our exports table."
      | Bool
otherwise =
          forall a. a -> Maybe a
Just EntryE {Client'
client :: Client'
$sel:client:EntryE :: Client'
client, $sel:refCount:EntryE :: Word32
refCount = Word32
refCount forall a. Num a => a -> a -> a
+ Word32
1}

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

acceptPayload :: Conn -> Raw R.Payload 'Const -> LimitT STM Payload
acceptPayload :: Conn -> Raw Payload 'Const -> LimitT STM Payload
acceptPayload Conn
conn Raw Payload 'Const
payload = do
  Vector (Parsed CapDescriptor)
capTable <- forall a b bp (m :: * -> *) (k :: FieldKind).
(IsStruct a, Parse b bp, ReadCtx m 'Const) =>
Field k a b -> Raw a 'Const -> m bp
parseField forall a. IsLabel "capTable" a => a
#capTable Raw Payload 'Const
payload
  Vector Client
clients <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\R.CapDescriptor {Parsed (Which CapDescriptor)
union' :: Parsed (Which CapDescriptor)
$sel:union':CapDescriptor :: Parsed CapDescriptor -> Parsed (Which CapDescriptor)
union'} -> Conn -> Parsed (Which CapDescriptor) -> STM Client
acceptCap Conn
conn Parsed (Which CapDescriptor)
union') Vector (Parsed CapDescriptor)
capTable
  Raw Unwrapped (Untyped (ReprFor (Maybe AnyPointer)) 'Const)
rawContent <- forall (k :: FieldKind) a b (mut :: Mutability) (m :: * -> *).
(IsStruct a, ReadCtx m mut) =>
Field k a b -> Raw a mut -> m (Raw b mut)
readField forall a. IsLabel "content" a => a
#content Raw Payload 'Const
payload
  RawMPtr
content <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
UntypedRaw.tMsg (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Client -> Message 'Const -> Message 'Const
Message.withCapTable Vector Client
clients)) Unwrapped (Untyped (ReprFor (Maybe AnyPointer)) 'Const)
rawContent
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Payload {RawMPtr
content :: RawMPtr
$sel:content:Payload :: RawMPtr
content, Vector (Parsed CapDescriptor)
capTable :: Vector (Parsed CapDescriptor)
$sel:capTable:Payload :: Vector (Parsed CapDescriptor)
capTable}

-- | 'acceptCap' is a dual of 'emitCap'; it derives a Client from a CapDescriptor'
-- received via the connection. May update connection state as necessary.
acceptCap :: Conn -> R.Parsed (Which R.CapDescriptor) -> STM Client
acceptCap :: Conn -> Parsed (Which CapDescriptor) -> STM Client
acceptCap Conn
conn Parsed (Which CapDescriptor)
cap = Conn -> STM Conn'
getLive Conn
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Conn'
conn' -> Conn' -> Parsed (Which CapDescriptor) -> STM Client
go Conn'
conn' Parsed (Which CapDescriptor)
cap
  where
    go :: Conn' -> Parsed (Which CapDescriptor) -> STM Client
go Conn'
_ Parsed (Which CapDescriptor)
R:ParsedWhich7
R.CapDescriptor'none = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Client' -> Client
wrapClient 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 <- 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 = forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show IEId
importId)
           in forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
                Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
                  Text
"received senderHosted capability #"
                    forall a. Semigroup a => a -> a -> a
<> Text
imp
                    forall a. Semigroup a => a -> a -> a
<> Text
", but the imports table says #"
                    forall a. Semigroup a => a -> a -> a
<> Text
imp
                    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
          forall a. Rc a -> STM ()
Rc.incr Rc ()
localRc
          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 forall a. Num a => a -> a -> a
+ Word32
1} IEId
importId Map IEId EntryI
imports
          Cell ImportRef
cell <-
            forall (m :: * -> *) a. MonadSTM m => a -> m (Cell a)
Fin.newCell
              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' forall a b. (a -> b) -> a -> b
$ forall a. Cell a -> IO () -> IO ()
Fin.addFinalizer Cell ImportRef
cell forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. Rc a -> STM ()
Rc.decr Rc ()
localRc
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
wrapClient forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Cell ImportRef -> Client'
ImportClient Cell ImportRef
cell
        Maybe EntryI
Nothing ->
          Maybe Client' -> Client
wrapClient forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cell ImportRef -> Client'
ImportClient 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 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 <- 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 = forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show IEId
importId)
           in forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
                Text -> Parsed Exception
eFailed forall a b. (a -> b) -> a -> b
$
                  Text
"received senderPromise capability #"
                    forall a. Semigroup a => a -> a -> a
<> Text
imp
                    forall a. Semigroup a => a -> a -> a
<> Text
", but the imports table says #"
                    forall a. Semigroup a => a -> a -> a
<> Text
imp
                    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
          forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert EntryI
ent {$sel:remoteRc:EntryI :: Word32
remoteRc = Word32
remoteRc forall a. Num a => a -> a -> a
+ Word32
1} IEId
importId Map IEId EntryI
imports
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            Maybe Client' -> Client
wrapClient forall a b. (a -> b) -> a -> b
$
              forall a. a -> Maybe a
Just
                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 (forall a. a -> Maybe a
Just (TVar PromiseState
pState, TmpDest
tmpDest))
              ImportRef {ExportMap
proxies :: ExportMap
$sel:proxies:ImportRef :: ImportRef -> ExportMap
proxies} <- forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
imp
              let tmpDest :: TmpDest
tmpDest = RemoteDest -> TmpDest
RemoteDest (Cell ImportRef -> RemoteDest
ImportDest Cell ImportRef
imp)
              TVar PromiseState
pState <- forall a. a -> STM (TVar a)
newTVar Pending {TmpDest
tmpDest :: TmpDest
$sel:tmpDest:Ready :: TmpDest
tmpDest}
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            Maybe Client' -> Client
wrapClient forall a b. (a -> b) -> a -> b
$
              forall a. a -> Maybe a
Just
                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 Parsed Word32
exportId) =
      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 Parsed Word32
exportId) forall a b. (a -> b) -> a -> b
$
        \EntryE {Client'
client :: Client'
$sel:client:EntryE :: EntryE -> Client'
client} ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
wrapClient forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Client'
client
    go Conn'
conn' (R.CapDescriptor'receiverAnswer Parsed PromisedAnswer
pa) = do
      PromisedAnswer
pa <- forall (m :: * -> *).
MonadThrow m =>
Parsed PromisedAnswer -> m PromisedAnswer
unmarshalPromisedAnswer Parsed PromisedAnswer
pa forall e a. Exception e => STM a -> (e -> STM a) -> STM a
`catchSTM` forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn'
      Conn' -> PromisedAnswer -> STM Client
newLocalAnswerClient Conn'
conn' PromisedAnswer
pa
    go Conn'
conn' (R.CapDescriptor'thirdPartyHosted Parsed ThirdPartyCapDescriptor
_) =
      -- Note [Level 3]
      forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
        Text -> Parsed Exception
eUnimplemented
          Text
"thirdPartyHosted unimplemented; level 3 is not supported."
    go Conn'
conn' (R.CapDescriptor'unknown' Word16
tag) =
      forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' forall a b. (a -> b) -> a -> b
$
        Text -> Parsed Exception
eUnimplemented forall a b. (a -> b) -> a -> b
$
          Text
"Unimplemented CapDescriptor variant #" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
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 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 <- forall a. a -> STM () -> STM (Rc a)
Rc.new () forall a b. (a -> b) -> a -> b
$ IEId -> Conn' -> STM ()
releaseImport IEId
importId Conn'
conn'
    ExportMap
proxies <- Map Conn IEId -> ExportMap
ExportMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value. STM (Map key value)
M.new
    let importRef :: ImportRef
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
            }
    forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
      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 <- forall (m :: * -> *) a. MonadSTM m => a -> m (Cell a)
Fin.newCell ImportRef
importRef
    Conn' -> IO () -> STM ()
queueIO Conn'
conn' forall a b. (a -> b) -> a -> b
$ forall a. Cell a -> IO () -> IO ()
Fin.addFinalizer Cell ImportRef
cell forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. Rc a -> STM ()
Rc.decr Rc ()
localRc
    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
  (Promise ()
_, Fulfiller ()
onSent) <- forall (m :: * -> *) a. MonadSTM m => m (Promise a, Fulfiller a)
newPromise
  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 forall a b. (a -> b) -> a -> b
$ \EntryI {Word32
remoteRc :: Word32
$sel:remoteRc:EntryI :: EntryI -> Word32
remoteRc} ->
    Conn' -> Parsed (Which Message) -> Fulfiller () -> STM ()
sendPureMsg
      Conn'
conn'
      ( Parsed Release -> Parsed (Which Message)
R.Message'release
          R.Release
            { $sel:id:Release :: Parsed Word32
id = IEId -> Word32
ieWord IEId
importId,
              $sel:referenceCount:Release :: Parsed Word32
referenceCount = Word32
remoteRc
            }
      )
      Fulfiller ()
onSent
  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 <- forall a. STM (TQueue a)
newTQueue
  let tmpDest :: TmpDest
tmpDest = LocalDest -> TmpDest
LocalDest forall a b. (a -> b) -> a -> b
$ LocalBuffer {TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: TQueue CallInfo
callBuffer}
  TVar PromiseState
pState <- forall a. a -> STM (TVar a)
newTVar 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 forall a b. (a -> b) -> a -> b
$
    TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn
      TmpDest
tmpDest
      (forall a. TVar a -> a -> STM ()
writeTVar TVar PromiseState
pState)
      Conn'
conn
      (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
transform)
  ExportMap
exportMap <- Map Conn IEId -> ExportMap
ExportMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value. STM (Map key value)
M.new
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Maybe Client' -> Client
wrapClient forall a b. (a -> b) -> a -> b
$
      forall a. a -> Maybe a
Just
        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.