{-# 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 Control.Concurrent.STM
import Control.Monad.STM.Class
import Control.Monad.Trans.Class
import Data.Word

import Capnp.New.Accessors
import Control.Concurrent       (threadDelay)
import Control.Concurrent.Async (concurrently_, race_)
import Control.Concurrent.MVar  (MVar, newEmptyMVar)
import Control.Exception.Safe
    ( Exception
    , MonadThrow
    , SomeException
    , bracket
    , finally
    , fromException
    , throwIO
    , throwM
    , try
    )
import Control.Monad            (forever, void, when)
import Data.Default             (Default(def))
import Data.Foldable            (for_, toList, traverse_)
import Data.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 GHC.Generics             (Generic)
import Supervisors              (Supervisor, superviseSTM, withSupervisor)
import System.Mem.StableName    (StableName, hashStableName, makeStableName)
import System.Timeout           (timeout)

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

import Capnp.Convert        (msgToRaw, parsedToMsg)
import Capnp.Fields         (Which)
import Capnp.Message        (Message)
import Capnp.Mutability     (Mutability(..), thaw)
import Capnp.New.Classes    (new, newRoot, parse)
import Capnp.Repr           (Raw(..))
import Capnp.Rpc.Errors
    ( eDisconnected
    , eFailed
    , eMethodUnimplemented
    , eUnimplemented
    , wrapException
    )
import Capnp.Rpc.Promise
    (Fulfiller, breakOrFulfill, breakPromise, fulfill, newCallback)
import Capnp.Rpc.Transport  (Transport(recvMsg, sendMsg))
import Capnp.TraversalLimit (LimitT, defaultLimit, evalLimitT)
import Internal.BuildPure   (createPure)
import Internal.Rc          (Rc)
import Internal.SnocList    (SnocList)

import qualified Capnp.Gen.Capnp.Rpc.New as R
import qualified Capnp.Message           as Message
import qualified Capnp.New.Basics        as B
import qualified Capnp.Rpc.Server        as Server
import qualified Capnp.Untyped           as UntypedRaw
import qualified Internal.Rc             as Rc
import qualified Internal.SnocList       as SnocList
import qualified Internal.TCloseQ        as TCloseQ
import qualified Lifetimes.Gc            as Fin

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

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

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


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

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

instance Exception RpcError

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

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

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

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

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

data LiveState
    = Live Conn'
    | Dead

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

-- | An entry in our questions or answers table.
data EntryQA
    -- | An entry for which we have neither sent/received a finish, nor
    -- a return. Contains two sets of callbacks, to invoke on each type
    -- of message.
    = NewQA
        { EntryQA -> SnocList (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
    { EntryI -> Rc ()
localRc      :: Rc ()
    -- ^ A refcount cell with a finalizer attached to it; when the finalizer
    -- runs it will remove this entry from the table and send a release
    -- message to the remote vat.
    , EntryI -> Word32
remoteRc     :: !Word32
    -- ^ The reference count for this object as understood by the remote
    -- vat. This tells us what to send in the release message's count field.
    , EntryI -> ExportMap
proxies      :: ExportMap
    -- ^ See Note [proxies]
    --
    , EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState :: Maybe
        ( TVar PromiseState
        , TmpDest -- origTarget field. TODO(cleanup): clean this up a bit.
        )
    -- ^ If this entry is a promise, this will contain the state of that
    -- promise, so that it may be used to create PromiseClients and
    -- update the promise when it resolves.
    }

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

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

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

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

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

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

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

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

data PipelineState
    = PendingRemotePipeline
        { PipelineState -> QAId
answerId  :: !QAId
        , PipelineState -> Map (SnocList Word16) Client
clientMap :: M.Map (SnocList Word16) Client
        , PipelineState -> Conn
conn      :: Conn
        }
    | PendingLocalPipeline (SnocList (Fulfiller RawMPtr))
    | ReadyPipeline (Either (R.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 p :: Pipeline
p@Pipeline{SnocList Word16
steps :: SnocList Word16
$sel:steps:Pipeline :: Pipeline -> SnocList Word16
steps} Word16
step =
    Pipeline
p { $sel:steps:Pipeline :: SnocList Word16
steps = SnocList Word16 -> Word16 -> SnocList Word16
forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList Word16
steps Word16
step }

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

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

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

-- | The current state of a 'PromiseClient'.
data PromiseState
    -- | The promise is fully resolved.
    = Ready
        { PromiseState -> Client
target :: Client
        -- ^ Capability to which the promise resolved.
        }
    -- | The promise has resolved, but is waiting on a Disembargo message
    -- before it is safe to send it messages.
    | Embargo
        { PromiseState -> TQueue CallInfo
callBuffer :: TQueue Server.CallInfo
        -- ^ A queue in which to buffer calls while waiting for the
        -- disembargo.
        }
    -- | The promise has not yet resolved.
    | Pending
        { PromiseState -> TmpDest
tmpDest :: TmpDest
        -- ^ A temporary destination to send calls, while we wait for the
        -- promise to resolve.
        }
    -- | The promise resolved to an exception.
    | Error (R.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
        { RemoteDest -> Conn
conn   :: Conn
        -- ^ The connection to the remote vat.
        , RemoteDest -> PromisedAnswer
answer :: PromisedAnswer
        -- ^ The answer to target.
        }
    -- | Send call messages to a remote vat, targeting an entry in our
    -- imports table.
    | ImportDest (Fin.Cell ImportRef)

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

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


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

-- The below correspond to the similarly named types in
-- rpc.capnp, except:
--
-- * They use our newtype wrappers for ids
-- * They don't have unknown variants
-- * AnyPointers are left un-parsed
-- * PromisedAnswer's transform field is just a list of pointer offsets,
--   rather than a union with no other actually-useful variants.
-- * PromisedAnswer's transform field is a SnocList, for efficient appending.
data MsgTarget
    = ImportTgt !IEId
    | AnswerTgt PromisedAnswer
data PromisedAnswer = PromisedAnswer
    { PromisedAnswer -> QAId
answerId  :: !QAId
    , PromisedAnswer -> SnocList Word16
transform :: SnocList Word16
    }
data Call = Call
    { Call -> QAId
questionId  :: !QAId
    , Call -> MsgTarget
target      :: !MsgTarget
    , Call -> Word64
interfaceId :: !Word64
    , Call -> Word16
methodId    :: !Word16
    , Call -> Payload
params      :: !Payload
    }
data Return = Return
    { Return -> QAId
answerId         :: !QAId
    , Return -> Bool
releaseParamCaps :: !Bool
    , Return -> Return'
union'           :: Return'
    }
data Return'
    = Return'results Payload
    | Return'exception (R.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 Pipeline
call :: CallInfo -> Client -> m Pipeline
call Server.CallInfo { Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response } (Client Maybe Client'
Nothing) = STM Pipeline -> m Pipeline
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM Pipeline -> m Pipeline) -> STM Pipeline -> m Pipeline
forall a b. (a -> b) -> a -> b
$ do
    Fulfiller RawMPtr -> Parsed Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response Parsed Exception
eMethodUnimplemented
    TVar PipelineState
state <- PipelineState -> STM (TVar PipelineState)
forall a. a -> STM (TVar a)
newTVar (PipelineState -> STM (TVar PipelineState))
-> PipelineState -> STM (TVar PipelineState)
forall a b. (a -> b) -> a -> b
$ Either (Parsed Exception) RawMPtr -> PipelineState
ReadyPipeline (Parsed Exception -> Either (Parsed Exception) RawMPtr
forall a b. a -> Either a b
Left Parsed Exception
eMethodUnimplemented)
    Pipeline -> STM Pipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipeline :: TVar PipelineState -> SnocList Word16 -> Pipeline
Pipeline{TVar PipelineState
state :: TVar PipelineState
$sel:state:Pipeline :: TVar PipelineState
state, $sel:steps:Pipeline :: SnocList Word16
steps = SnocList Word16
forall a. Monoid a => a
mempty}
call info :: CallInfo
info@Server.CallInfo { Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response } (Client (Just Client'
client')) = STM Pipeline -> m Pipeline
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM Pipeline -> m Pipeline) -> STM Pipeline -> m Pipeline
forall a b. (a -> b) -> a -> b
$ do
    (Pipeline
localPipeline, Fulfiller RawMPtr
response') <- Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr)
makeLocalPipeline Fulfiller RawMPtr
response
    let info' :: CallInfo
info' = CallInfo
info { response :: Fulfiller RawMPtr
Server.response = Fulfiller RawMPtr
response' }
    case Client'
client' of
        LocalClient { Rc (CallInfo -> STM ())
qCall :: Rc (CallInfo -> STM ())
$sel:qCall:LocalClient :: Client' -> Rc (CallInfo -> STM ())
qCall } -> do
            Rc (CallInfo -> STM ()) -> STM (Maybe (CallInfo -> STM ()))
forall a. Rc a -> STM (Maybe a)
Rc.get Rc (CallInfo -> STM ())
qCall STM (Maybe (CallInfo -> STM ()))
-> (Maybe (CallInfo -> STM ()) -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just CallInfo -> STM ()
q -> do
                    CallInfo -> STM ()
q CallInfo
info'
                Maybe (CallInfo -> STM ())
Nothing ->
                    Fulfiller RawMPtr -> Parsed Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response' Parsed Exception
eDisconnected
            Pipeline -> STM Pipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipeline
localPipeline

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

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

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

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

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

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

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

makeLocalPipeline :: Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr)
makeLocalPipeline :: Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr)
makeLocalPipeline Fulfiller RawMPtr
f = do
    TVar PipelineState
state <- PipelineState -> STM (TVar PipelineState)
forall a. a -> STM (TVar a)
newTVar (PipelineState -> STM (TVar PipelineState))
-> PipelineState -> STM (TVar PipelineState)
forall a b. (a -> b) -> a -> b
$ SnocList (Fulfiller RawMPtr) -> PipelineState
PendingLocalPipeline SnocList (Fulfiller RawMPtr)
forall a. Monoid a => a
mempty
    Fulfiller RawMPtr
f' <- (Either (Parsed Exception) RawMPtr -> STM ())
-> STM (Fulfiller RawMPtr)
forall (m :: * -> *) a.
MonadSTM m =>
(Either (Parsed Exception) a -> STM ()) -> m (Fulfiller a)
newCallback ((Either (Parsed Exception) RawMPtr -> STM ())
 -> STM (Fulfiller RawMPtr))
-> (Either (Parsed Exception) RawMPtr -> STM ())
-> STM (Fulfiller RawMPtr)
forall a b. (a -> b) -> a -> b
$ \Either (Parsed Exception) RawMPtr
r -> do
        PipelineState
s <- TVar PipelineState -> STM PipelineState
forall a. TVar a -> STM a
readTVar TVar PipelineState
state
        case PipelineState
s of
            PendingLocalPipeline SnocList (Fulfiller RawMPtr)
fs -> do
                TVar PipelineState -> PipelineState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PipelineState
state (Either (Parsed Exception) RawMPtr -> PipelineState
ReadyPipeline Either (Parsed Exception) RawMPtr
r)
                Fulfiller RawMPtr -> Either (Parsed Exception) RawMPtr -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Either (Parsed Exception) a -> m ()
breakOrFulfill Fulfiller RawMPtr
f Either (Parsed Exception) RawMPtr
r
                (Fulfiller RawMPtr -> STM ())
-> SnocList (Fulfiller RawMPtr) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Fulfiller RawMPtr -> Either (Parsed Exception) RawMPtr -> STM ()
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.
                String -> STM ()
forall a. HasCallStack => String -> a
error String
"impossible"
    (Pipeline, Fulfiller RawMPtr) -> STM (Pipeline, Fulfiller RawMPtr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pipeline :: TVar PipelineState -> SnocList Word16 -> Pipeline
Pipeline{TVar PipelineState
state :: TVar PipelineState
$sel:state:Pipeline :: TVar PipelineState
state, $sel:steps:Pipeline :: SnocList Word16
steps = SnocList Word16
forall a. Monoid a => a
mempty}, Fulfiller RawMPtr
f')

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

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

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

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

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

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

        Return'acceptFromThirdParty RawMPtr
_ ->
            -- Note [Level 3]
            Conn' -> Parsed Exception -> STM ()
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
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' (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ Conn' -> Parsed Finish -> STM ()
finishQuestion Conn'
conn' R:ParsedFinish
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
Parsed Bool
False
        }


marshalMsgTarget :: MsgTarget -> R.Parsed R.MessageTarget
marshalMsgTarget :: MsgTarget -> Parsed MessageTarget
marshalMsgTarget = \case
    ImportTgt IEId
importId ->
        Parsed (Which MessageTarget) -> Parsed MessageTarget
R.MessageTarget (Parsed (Which MessageTarget) -> Parsed MessageTarget)
-> Parsed (Which MessageTarget) -> Parsed 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 (Parsed (Which MessageTarget) -> Parsed MessageTarget)
-> Parsed (Which MessageTarget) -> Parsed MessageTarget
forall a b. (a -> b) -> a -> b
$ Parsed PromisedAnswer -> Parsed (Which MessageTarget)
R.MessageTarget'promisedAnswer (Parsed PromisedAnswer -> Parsed (Which MessageTarget))
-> Parsed PromisedAnswer -> Parsed (Which MessageTarget)
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 } =
    PromisedAnswer :: Parsed Word32
-> Parsed (List PromisedAnswer'Op) -> Parsed PromisedAnswer
R.PromisedAnswer
        { $sel:questionId:PromisedAnswer :: Parsed Word32
R.questionId = QAId -> Word32
qaWord QAId
answerId
        , $sel:transform:PromisedAnswer :: Parsed (List PromisedAnswer'Op)
R.transform =
            [Parsed PromisedAnswer'Op] -> Vector (Parsed PromisedAnswer'Op)
forall a. [a] -> Vector a
V.fromList ([Parsed PromisedAnswer'Op] -> Vector (Parsed PromisedAnswer'Op))
-> [Parsed PromisedAnswer'Op] -> Vector (Parsed PromisedAnswer'Op)
forall a b. (a -> b) -> a -> b
$ (Word16 -> Parsed PromisedAnswer'Op)
-> [Word16] -> [Parsed PromisedAnswer'Op]
forall a b. (a -> b) -> [a] -> [b]
map
                (Parsed (Which PromisedAnswer'Op) -> Parsed PromisedAnswer'Op
R.PromisedAnswer'Op (Parsed (Which PromisedAnswer'Op) -> Parsed PromisedAnswer'Op)
-> (Word16 -> Parsed (Which PromisedAnswer'Op))
-> Word16
-> Parsed PromisedAnswer'Op
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Parsed (Which PromisedAnswer'Op)
Parsed Word16 -> Parsed (Which PromisedAnswer'Op)
R.PromisedAnswer'Op'getPointerField)
                (SnocList Word16 -> [Word16]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SnocList Word16
transform)
        }

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

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


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

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


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


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


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

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

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

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

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

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

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

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

handleAbortMsg :: Conn -> R.Parsed R.Exception -> STM ()
handleAbortMsg :: Conn -> Parsed Exception -> STM ()
handleAbortMsg Conn
_ Parsed Exception
exn =
    RpcError -> STM ()
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 msg) = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Conn'
conn' -> case Parsed (Which Message)
msg of
    R.Message'unimplemented _ ->
        -- If the client itself doesn't handle unimplemented messages, that's
        -- weird, but ultimately their problem.
        () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    R.Message'abort _ ->
        Conn' -> Parsed Exception -> STM ()
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed (Text -> Parsed Exception) -> Text -> Parsed Exception
forall a b. (a -> b) -> a -> b
$
            Text
"Your vat sent an 'unimplemented' message for an abort message " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"that its remote peer never sent. This is likely a bug in your " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"capnproto library."
    Parsed (Which Message)
_ ->
        Conn' -> Parsed Exception -> STM ()
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
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{ questionId } = Conn -> STM Conn'
getLive Conn
conn STM Conn' -> (Conn' -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Conn'
conn' -> do
    Return
ret <- case Conn' -> Maybe Client
bootstrap Conn'
conn' of
        Maybe Client
Nothing ->
            Return -> STM Return
forall (f :: * -> *) a. Applicative f => a -> f a
pure Return :: QAId -> Bool -> Return' -> Return
Return
                { $sel:answerId:Return :: QAId
answerId = Word32 -> QAId
QAId Word32
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 (Parsed Exception -> Return') -> Parsed Exception -> Return'
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 <- (Ptr 'Const -> RawMPtr) -> STM (Ptr 'Const) -> STM RawMPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr 'Const -> RawMPtr
forall a. a -> Maybe a
Just (STM (Ptr 'Const) -> STM RawMPtr)
-> STM (Ptr 'Const) -> STM RawMPtr
forall a b. (a -> b) -> a -> b
$ WordCount
-> (forall s. PureBuilder s (Ptr ('Mut s))) -> STM (Ptr 'Const)
forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure WordCount
defaultLimit ((forall s. PureBuilder s (Ptr ('Mut s))) -> STM (Ptr 'Const))
-> (forall s. PureBuilder s (Ptr ('Mut s))) -> STM (Ptr 'Const)
forall a b. (a -> b) -> a -> b
$ do
                Message ('Mut s)
msg <- Maybe WordCount -> PureBuilder s (Message ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Maybe WordCount -> m (Message ('Mut s))
Message.newMessage Maybe WordCount
forall a. Maybe a
Nothing
                Cap ('Mut s) -> Ptr ('Mut s)
forall (mut :: Mutability). Cap mut -> Ptr mut
UntypedRaw.PtrCap (Cap ('Mut s) -> Ptr ('Mut s))
-> PureBuilder s (Cap ('Mut s)) -> PureBuilder s (Ptr ('Mut s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message ('Mut s) -> Client -> PureBuilder s (Cap ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m (Cap ('Mut s))
UntypedRaw.appendCap Message ('Mut s)
msg Client
client
            Return -> STM Return
forall (f :: * -> *) a. Applicative f => a -> f a
pure Return :: QAId -> Bool -> Return' -> Return
Return
                { $sel:answerId:Return :: QAId
answerId = Word32 -> QAId
QAId Word32
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 -> Vector (Parsed CapDescriptor) -> Payload
Payload
                        { RawMPtr
content :: RawMPtr
$sel:content:Payload :: RawMPtr
content
                        , $sel:capTable:Payload :: Vector (Parsed CapDescriptor)
capTable = Parsed CapDescriptor -> Vector (Parsed CapDescriptor)
forall a. a -> Vector a
V.singleton
                            (R:ParsedCapDescriptor
forall a. Default a => a
def { $sel:union':CapDescriptor :: Parsed (Which CapDescriptor)
R.union' = Parsed (Which CapDescriptor)
capDesc } :: R.Parsed R.CapDescriptor)
                        }
                }
    Focus EntryQA STM () -> QAId -> Map QAId EntryQA -> STM ()
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
M.focus
        ((Maybe EntryQA -> STM (Maybe EntryQA)) -> Focus EntryQA STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> m (Maybe a)) -> Focus a m ()
Focus.alterM ((Maybe EntryQA -> STM (Maybe EntryQA)) -> Focus EntryQA STM ())
-> (Maybe EntryQA -> STM (Maybe EntryQA)) -> Focus EntryQA STM ()
forall a b. (a -> b) -> a -> b
$ Conn' -> Return -> Maybe EntryQA -> STM (Maybe EntryQA)
insertBootstrap Conn'
conn' Return
ret)
        (Word32 -> QAId
QAId Word32
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 =
        Maybe EntryQA -> STM (Maybe EntryQA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EntryQA -> STM (Maybe EntryQA))
-> Maybe EntryQA -> STM (Maybe EntryQA)
forall a b. (a -> b) -> a -> b
$ EntryQA -> Maybe EntryQA
forall a. a -> Maybe a
Just HaveReturn :: Return -> SnocList (Parsed Finish -> STM ()) -> EntryQA
HaveReturn
            { $sel:returnMsg:NewQA :: Return
returnMsg = Return
ret
            , $sel:onFinish:NewQA :: SnocList (Parsed Finish -> STM ())
onFinish = [Parsed Finish -> STM ()] -> SnocList (Parsed Finish -> STM ())
forall a. [a] -> SnocList a
SnocList.fromList
                [ \R.Finish{releaseResultCaps} ->
                    case Return
ret of
                        Return
                            { $sel:union':Return :: Return -> Return'
union' = Return'results Payload
                                { $sel:capTable:Payload :: Payload -> Vector (Parsed CapDescriptor)
capTable = (Vector (Parsed CapDescriptor) -> [Parsed CapDescriptor]
forall a. Vector a -> [a]
V.toList -> [ R.CapDescriptor { union' = R.CapDescriptor'receiverHosted (IEId -> eid) } ])
                                }
                            } ->
                                Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
Parsed Bool
releaseResultCaps (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
                                    Conn -> Word32 -> IEId -> STM ()
releaseExport Conn
conn Word32
1 IEId
eid
                        Return
_ ->
                            () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                ]

            }
    insertBootstrap Conn'
conn' Return
_ (Just EntryQA
_) =
        Conn' -> Parsed Exception -> STM (Maybe EntryQA)
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' (Parsed Exception -> STM (Maybe EntryQA))
-> Parsed Exception -> STM (Maybe EntryQA)
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} <- STM Conn' -> LimitT STM Conn'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM Conn' -> LimitT STM Conn') -> STM Conn' -> LimitT STM Conn'
forall a b. (a -> b) -> a -> b
$ Conn -> STM Conn'
getLive Conn
conn
    Word32
questionId <- Field 'Slot Call Word32 -> Raw Call 'Const -> LimitT STM Word32
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 IsLabel "questionId" (Field 'Slot Call Word32)
Field 'Slot Call Word32
#questionId Raw Call 'Const
callMsg
    R.MessageTarget target <- Field 'Slot Call MessageTarget
-> Raw Call 'Const -> LimitT STM (Parsed MessageTarget)
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 IsLabel "target" (Field 'Slot Call MessageTarget)
Field 'Slot Call MessageTarget
#target Raw Call 'Const
callMsg
    Word64
interfaceId <- Field 'Slot Call Word64 -> Raw Call 'Const -> LimitT STM Word64
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 IsLabel "interfaceId" (Field 'Slot Call Word64)
Field 'Slot Call Word64
#interfaceId Raw Call 'Const
callMsg
    Word16
methodId <- Field 'Slot Call Word16 -> Raw Call 'Const -> LimitT STM Word16
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 IsLabel "methodId" (Field 'Slot Call Word16)
Field 'Slot Call Word16
#methodId Raw Call 'Const
callMsg
    Raw Payload 'Const
payload <- Field 'Slot Call Payload
-> Raw Call 'Const -> LimitT STM (Raw Payload 'Const)
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 IsLabel "params" (Field 'Slot Call Payload)
Field 'Slot Call Payload
#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

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

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

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

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

ptrClient :: UntypedRaw.ReadCtx m 'Const => RawMPtr -> m Client
ptrClient :: RawMPtr -> m Client
ptrClient RawMPtr
Nothing = Client -> m Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
nullClient
ptrClient (Just (UntypedRaw.PtrCap Cap 'Const
cap)) = Cap 'Const -> m Client
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
UntypedRaw.getClient Cap 'Const
cap
ptrClient (Just Ptr 'Const
_) = Parsed Exception -> m Client
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Parsed Exception -> m Client) -> Parsed Exception -> m Client
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 :: [Word16] -> RawMPtr -> m RawMPtr
followPtrs [] RawMPtr
ptr =
    RawMPtr -> m RawMPtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawMPtr
ptr
followPtrs (Word16
_:[Word16]
_) RawMPtr
Nothing =
    RawMPtr -> m RawMPtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawMPtr
forall a. Maybe a
Nothing
followPtrs (Word16
i:[Word16]
is) (Just (UntypedRaw.PtrStruct Struct 'Const
struct)) =
    Int -> Struct 'Const -> m RawMPtr
forall (m :: * -> *) (msg :: Mutability).
ReadCtx m msg =>
Int -> Struct msg -> m (Maybe (Ptr msg))
UntypedRaw.getPtr (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i) Struct 'Const
struct m RawMPtr -> (RawMPtr -> m RawMPtr) -> m RawMPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Word16] -> RawMPtr -> m RawMPtr
forall (m :: * -> *).
ReadCtx m 'Const =>
[Word16] -> RawMPtr -> m RawMPtr
followPtrs [Word16]
is
followPtrs (Word16
_:[Word16]
_) (Just Ptr 'Const
_) =
    Parsed Exception -> m RawMPtr
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Parsed Exception -> m RawMPtr) -> Parsed Exception -> m RawMPtr
forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed Text
"Tried to access pointer field of non-struct."

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Generate a cap table describing the capabilities reachable from the given
-- pointer. The capability table will be correct for any message where all of
-- the capabilities are within the subtree under the pointer.
genSendableCapTableRaw
    :: Conn
    -> Maybe (UntypedRaw.Ptr 'Const)
    -> STM (V.Vector (R.Parsed R.CapDescriptor))
genSendableCapTableRaw :: Conn -> RawMPtr -> STM (Vector (Parsed CapDescriptor))
genSendableCapTableRaw Conn
_ RawMPtr
Nothing = Vector (Parsed CapDescriptor)
-> STM (Vector (Parsed CapDescriptor))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector (Parsed CapDescriptor)
forall a. Vector a
V.empty
genSendableCapTableRaw Conn
conn (Just Ptr 'Const
ptr) =
    (Client -> STM (Parsed CapDescriptor))
-> Vector Client -> STM (Vector (Parsed CapDescriptor))
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
            Parsed CapDescriptor -> STM (Parsed CapDescriptor)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parsed CapDescriptor
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 (Unwrapped (Ptr 'Const) -> Message 'Const
forall (f :: Mutability -> *) (mut :: Mutability).
HasMessage f =>
Unwrapped (f mut) -> Message mut
UntypedRaw.message @UntypedRaw.Ptr Unwrapped (Ptr 'Const)
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
    Payload -> STM Payload
forall (f :: * -> *) a. Applicative f => a -> f a
pure Payload :: RawMPtr -> Vector (Parsed CapDescriptor) -> Payload
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) -> STM ()
sendPureMsg :: Conn' -> Parsed (Which Message) -> STM ()
sendPureMsg Conn'{TBQueue (Message 'Const)
sendQ :: TBQueue (Message 'Const)
$sel:sendQ:Conn' :: Conn' -> TBQueue (Message 'Const)
sendQ} Parsed (Which Message)
msg =
    WordCount
-> (forall s. PureBuilder s (Message ('Mut s)))
-> STM (Message 'Const)
forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure WordCount
forall a. Bounded a => a
maxBound (Parsed Message -> PureBuilder s (Message ('Mut s))
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)) STM (Message 'Const) -> (Message 'Const -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TBQueue (Message 'Const) -> Message 'Const -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Message 'Const)
sendQ

-- | Send a finish message, updating connection state and triggering
-- callbacks as necessary.
finishQuestion :: Conn' -> R.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{questionId} = do
    -- arrange for the question ID to be returned to the pool once
    -- the return has also been received:
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (Return -> STM ())
-> STM ()
subscribeReturn Text
"question" Conn'
conn Map QAId EntryQA
questions (Word32 -> QAId
QAId Word32
Parsed Word32
questionId) ((Return -> STM ()) -> STM ()) -> (Return -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \Return
_ ->
        Conn' -> QAId -> STM ()
freeQuestion Conn'
conn (Word32 -> QAId
QAId Word32
Parsed Word32
questionId)
    Conn' -> Parsed (Which Message) -> STM ()
sendPureMsg Conn'
conn (Parsed (Which Message) -> STM ())
-> Parsed (Which Message) -> STM ()
forall a b. (a -> b) -> a -> b
$ Parsed Finish -> Parsed (Which Message)
R.Message'finish Parsed Finish
Parsed Finish
finish
    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} =
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (EntryQA -> STM ())
-> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
tableName Conn'
conn Map QAId EntryQA
table QAId
answerId ((EntryQA -> STM ()) -> STM ()) -> (EntryQA -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
        NewQA{SnocList (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
            EntryQA -> QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
                HaveReturn :: Return -> SnocList (Parsed Finish -> STM ()) -> EntryQA
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
            ((Return -> STM ()) -> STM ())
-> SnocList (Return -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Return -> STM ()) -> Return -> STM ()
forall a b. (a -> b) -> a -> b
$ Return
ret) SnocList (Return -> STM ())
onReturn
        HaveFinish{SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
$sel:onReturn:NewQA :: EntryQA -> SnocList (Return -> STM ())
onReturn} -> do
            QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete QAId
answerId Map QAId EntryQA
table
            ((Return -> STM ()) -> STM ())
-> SnocList (Return -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Return -> STM ()) -> Return -> STM ()
forall a b. (a -> b) -> a -> b
$ Return
ret) SnocList (Return -> STM ())
onReturn
        HaveReturn{} ->
            Conn' -> Parsed Exception -> STM ()
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed (Text -> Parsed Exception) -> Text -> Parsed Exception
forall a b. (a -> b) -> a -> b
$
                Text
"Duplicate return message for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (QAId -> String
forall a. Show a => a -> String
show QAId
answerId)

updateQAFinish :: Conn' -> M.Map QAId EntryQA -> Text -> R.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{questionId} =
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (EntryQA -> STM ())
-> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
tableName Conn'
conn Map QAId EntryQA
table (Word32 -> QAId
QAId Word32
Parsed Word32
questionId) ((EntryQA -> STM ()) -> STM ()) -> (EntryQA -> STM ()) -> STM ()
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
            ((Parsed Finish -> STM ()) -> STM ())
-> SnocList (Parsed Finish -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Parsed Finish -> STM ()) -> Parsed Finish -> STM ()
forall a b. (a -> b) -> a -> b
$ Parsed Finish
finish) SnocList (Parsed Finish -> STM ())
onFinish
            EntryQA -> QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert
                HaveFinish :: Parsed Finish -> SnocList (Return -> STM ()) -> EntryQA
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 Word32
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
            ((Parsed Finish -> STM ()) -> STM ())
-> SnocList (Parsed Finish -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Parsed Finish -> STM ()) -> Parsed Finish -> STM ()
forall a b. (a -> b) -> a -> b
$ Parsed Finish
finish) SnocList (Parsed Finish -> STM ())
onFinish
            QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
M.delete (Word32 -> QAId
QAId Word32
Parsed Word32
questionId) Map QAId EntryQA
table
        HaveFinish{} ->
            Conn' -> Parsed Exception -> STM ()
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed (Text -> Parsed Exception) -> Text -> Parsed Exception
forall a b. (a -> b) -> a -> b
$
                Text
"Duplicate finish message for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word32 -> String
forall a. Show a => a -> String
show Word32
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 =
    Text
-> Conn'
-> Map QAId EntryQA
-> QAId
-> (EntryQA -> STM ())
-> STM ()
forall k v a.
(Eq k, Hashable k, Show k) =>
Text -> Conn' -> Map k v -> k -> (v -> STM a) -> STM a
lookupAbort Text
tableName Conn'
conn Map QAId EntryQA
table QAId
qaId ((EntryQA -> STM ()) -> STM ()) -> (EntryQA -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \EntryQA
qa -> do
        EntryQA
new <- EntryQA -> STM EntryQA
go EntryQA
qa
        EntryQA -> QAId -> Map QAId EntryQA -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert EntryQA
new QAId
qaId Map QAId EntryQA
table
  where
    go :: EntryQA -> STM EntryQA
go = \case
        NewQA{SnocList (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} ->
            EntryQA -> STM EntryQA
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewQA :: SnocList (Parsed Finish -> STM ())
-> SnocList (Return -> STM ()) -> EntryQA
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 = SnocList (Return -> STM ())
-> (Return -> STM ()) -> SnocList (Return -> STM ())
forall a. SnocList a -> a -> SnocList a
SnocList.snoc SnocList (Return -> STM ())
onReturn Return -> STM ()
onRet
                }

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

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

-- | Abort the connection, sending an abort message. This is only safe to call
-- from within either the thread running the coordinator or the callback loop.
abortConn :: Conn' -> R.Parsed R.Exception -> STM a
abortConn :: Conn' -> Parsed Exception -> STM a
abortConn Conn'
_ Parsed Exception
e = RpcError -> STM a
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} = TVar LiveState -> STM LiveState
forall a. TVar a -> STM a
readTVar TVar LiveState
liveState STM LiveState -> (LiveState -> STM Conn') -> STM Conn'
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Live Conn'
conn' -> Conn' -> STM Conn'
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conn'
conn'
    LiveState
Dead       -> Parsed Exception -> STM Conn'
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 = TVar LiveState -> STM LiveState
forall a. TVar a -> STM a
readTVar TVar LiveState
liveState STM LiveState -> (LiveState -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Live Conn'
conn' -> Conn' -> STM ()
f Conn'
conn'
    LiveState
Dead       -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

-- | Resolve a promised client to an exception. See Note [resolveClient]
resolveClientExn :: TmpDest -> (PromiseState -> STM ()) -> R.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 <- TQueue CallInfo -> STM [CallInfo]
forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer
            (CallInfo -> STM ()) -> [CallInfo] -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
                (\Server.CallInfo{Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response} ->
                    Fulfiller RawMPtr -> Parsed Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller RawMPtr
response Parsed Exception
exn)
                [CallInfo]
calls
        RemoteDest AnswerDest {} ->
            () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        RemoteDest (ImportDest Cell ImportRef
_) ->
            () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PromiseState -> STM ()
resolve (PromiseState -> STM ()) -> PromiseState -> STM ()
forall a b. (a -> b) -> a -> b
$ 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' <- WordCount -> LimitT STM Client -> STM Client
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT STM Client -> STM Client)
-> LimitT STM Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Cap 'Const -> LimitT STM Client
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
UntypedRaw.getClient Cap 'Const
c
        TmpDest -> (PromiseState -> STM ()) -> Client -> STM ()
resolveClientClient TmpDest
tmpDest PromiseState -> STM ()
resolve Client
c'
    Just Ptr 'Const
_ ->
        TmpDest -> (PromiseState -> STM ()) -> Parsed Exception -> STM ()
resolveClientExn TmpDest
tmpDest PromiseState -> STM ()
resolve (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
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'
client) =
    case (Maybe Client'
client, TmpDest
tmpDest) of
        -- Remote resolved to local; we need to embargo:
        ( Just LocalClient{}, RemoteDest RemoteDest
dest ) ->
            RemoteDest -> STM ()
disembargoAndResolve RemoteDest
dest
        ( Just PromiseClient { $sel:origTarget:LocalClient :: Client' -> TmpDest
origTarget=LocalDest LocalDest
_ }, RemoteDest RemoteDest
dest) ->
            RemoteDest -> STM ()
disembargoAndResolve RemoteDest
dest
        ( Maybe Client'
Nothing, RemoteDest RemoteDest
dest ) ->
            -- It's not clear to me what we should actually do if the promise
            -- resolves to nullClient, but this can be encoded at the protocol
            -- level, so we have to deal with it. Possible options:
            --
            -- 1. Perhaps this is simply illegal, and we should send an abort?
            -- 2. Treat it as resolving to a local promise, in which case we
            --    need to send a disembargo as above.
            -- 3. Treat is as resolving to a remote promise, in which case we
            --    can't send an embargo.
            --
            -- (3) doesn't seem possible to implement quite correctly, since
            -- if we just resolve to nullClient right away, further calls will
            -- start returning exceptions before outstanding calls return -- we
            -- really do want to send a disembargo, but we can't because the
            -- protocol insists that we don't if the promise resolves to a
            -- remote cap.
            --
            -- What we currently do is (2); I(zenhack) intend to ask for
            -- clarification on the mailing list.
            RemoteDest -> STM ()
disembargoAndResolve RemoteDest
dest

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

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

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

    -- Flush the call buffer into the client's queue, and then pass the client
    -- to resolve.
    flushAndResolve :: TQueue CallInfo -> STM ()
flushAndResolve TQueue CallInfo
callBuffer = do
        TQueue CallInfo -> STM [CallInfo]
forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer STM [CallInfo] -> ([CallInfo] -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CallInfo -> STM Pipeline) -> [CallInfo] -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (CallInfo -> Client -> STM Pipeline
forall (m :: * -> *).
MonadSTM m =>
CallInfo -> Client -> m Pipeline
`call` Maybe Client' -> Client
Client Maybe Client'
client)
        PromiseState -> STM ()
resolve (PromiseState -> STM ()) -> PromiseState -> STM ()
forall a b. (a -> b) -> a -> b
$ Client -> PromiseState
Ready (Maybe Client' -> Client
Client Maybe Client'
client)
    flushAndRaise :: TQueue CallInfo -> Parsed Exception -> STM ()
flushAndRaise TQueue CallInfo
callBuffer Parsed Exception
e =
        TQueue CallInfo -> STM [CallInfo]
forall a. TQueue a -> STM [a]
flushTQueue TQueue CallInfo
callBuffer STM [CallInfo] -> ([CallInfo] -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            (CallInfo -> STM ()) -> [CallInfo] -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Server.CallInfo{Fulfiller RawMPtr
response :: Fulfiller RawMPtr
response :: CallInfo -> Fulfiller RawMPtr
response} -> Fulfiller RawMPtr -> Parsed Exception -> STM ()
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
        TVar LiveState -> STM LiveState
forall a. TVar a -> STM a
readTVar TVar LiveState
liveState STM LiveState -> (LiveState -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Live Conn'
conn' -> do
                TQueue CallInfo
callBuffer <- STM (TQueue CallInfo)
forall a. STM (TQueue a)
newTQueue
                MsgTarget
target <- RemoteDest -> STM MsgTarget
destTarget RemoteDest
dest
                Conn'
-> MsgTarget -> (Either (Parsed Exception) () -> STM ()) -> STM ()
disembargo Conn'
conn' MsgTarget
target ((Either (Parsed Exception) () -> STM ()) -> STM ())
-> (Either (Parsed Exception) () -> STM ()) -> STM ()
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 (PromiseState -> STM ()) -> PromiseState -> STM ()
forall a b. (a -> b) -> a -> b
$ Embargo :: TQueue CallInfo -> PromiseState
Embargo { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:Ready :: TQueue CallInfo
callBuffer }
            LiveState
Dead ->
                TmpDest -> (PromiseState -> STM ()) -> 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 <- (Either (Parsed Exception) () -> STM ()) -> STM (Fulfiller ())
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
    Fulfiller () -> EmbargoId -> Map EmbargoId (Fulfiller ()) -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert Fulfiller ()
callback EmbargoId
eid Map EmbargoId (Fulfiller ())
embargos
    Conn' -> Parsed (Which Message) -> STM ()
sendPureMsg Conn'
conn (Parsed (Which Message) -> STM ())
-> Parsed (Which Message) -> STM ()
forall a b. (a -> b) -> a -> b
$ Parsed Disembargo -> Parsed (Which Message)
R.Message'disembargo Disembargo :: Parsed MessageTarget
-> Parsed Disembargo'context -> Parsed 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' (Parsed (Which Disembargo'context) -> Parsed Disembargo'context)
-> Parsed (Which Disembargo'context) -> Parsed Disembargo'context
forall a b. (a -> b) -> a -> b
$
            Parsed Word32 -> Parsed (Which Disembargo'context)
R.Disembargo'context'senderLoopback (EmbargoId -> Word32
embargoWord EmbargoId
eid)
        }

-- | Resolve a promised client to the result of a return. See Note [resolveClient]
--
-- The [Word16] is a list of pointer indexes to follow from the result.
resolveClientReturn :: TmpDest -> (PromiseState -> STM ()) -> Conn' -> [Word16] -> Return -> STM ()
resolveClientReturn :: TmpDest
-> (PromiseState -> STM ())
-> Conn'
-> [Word16]
-> Return
-> STM ()
resolveClientReturn TmpDest
tmpDest PromiseState -> STM ()
resolve conn :: Conn'
conn@Conn'{Map QAId EntryQA
answers :: Map QAId EntryQA
$sel:answers:Conn' :: Conn' -> Map QAId EntryQA
answers} [Word16]
transform Return { Return'
union' :: Return'
$sel:union':Return :: Return -> Return'
union' } = case Return'
union' of
    -- TODO(cleanup) there is a lot of redundency betwen this and cbCallReturn; can
    -- we refactor?
    Return'exception 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 <- STM RawMPtr -> STM (Either (Parsed Exception) RawMPtr)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (STM RawMPtr -> STM (Either (Parsed Exception) RawMPtr))
-> STM RawMPtr -> STM (Either (Parsed Exception) RawMPtr)
forall a b. (a -> b) -> a -> b
$ WordCount -> LimitT STM RawMPtr -> STM RawMPtr
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT STM RawMPtr -> STM RawMPtr)
-> LimitT STM RawMPtr -> STM RawMPtr
forall a b. (a -> b) -> a -> b
$ [Word16] -> RawMPtr -> LimitT STM RawMPtr
forall (m :: * -> *).
ReadCtx m 'Const =>
[Word16] -> RawMPtr -> m RawMPtr
followPtrs [Word16]
transform RawMPtr
content
        case Either (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 (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
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.
        Conn' -> Parsed Exception -> STM ()
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed (Text -> Parsed Exception) -> Text -> Parsed Exception
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Received Return.resultsSentElsewhere for a call "
            , Text
"with sendResultsTo = caller."
            ]

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

    Return'acceptFromThirdParty RawMPtr
_ ->
        -- Note [Level 3]
        Conn' -> Parsed Exception -> STM ()
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn (Parsed Exception -> STM ()) -> Parsed Exception -> STM ()
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 STM Conn' -> (Conn' -> STM IEId) -> STM IEId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \conn' :: Conn'
conn'@Conn'{Map IEId EntryE
exports :: Map IEId EntryE
$sel:exports:Conn' :: Conn' -> Map IEId EntryE
exports} -> do
    ExportMap Map Conn IEId
m <- Client' -> STM ExportMap
clientExportMap Client'
client
    Maybe IEId
val <- Conn -> Map Conn IEId -> STM (Maybe IEId)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup Conn
conn Map Conn IEId
m
    case Maybe IEId
val of
        Just IEId
eid -> do
            IEId -> Client' -> Map IEId EntryE -> STM ()
addBumpExport IEId
eid Client'
client Map IEId EntryE
exports
            IEId -> STM IEId
forall (f :: * -> *) a. Applicative f => a -> f a
pure IEId
eid

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

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

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

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

-- | Generate a CapDescriptor', which we can send to the connection's remote
-- vat to identify client. In the process, this may allocate export ids, update
-- reference counts, and so forth.
emitCap :: Conn -> Client -> STM (R.Parsed (Which R.CapDescriptor))
emitCap :: Conn -> Client -> STM (Parsed (Which CapDescriptor))
emitCap Conn
_targetConn (Client Maybe Client'
Nothing) =
    Parsed (Which CapDescriptor) -> STM (Parsed (Which CapDescriptor))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Parsed (Which CapDescriptor)
R.CapDescriptor'none
emitCap Conn
targetConn (Client (Just Client'
client')) = case Client'
client' of
    LocalClient{} ->
        Word32 -> Parsed (Which CapDescriptor)
Parsed Word32 -> Parsed (Which CapDescriptor)
R.CapDescriptor'senderHosted (Word32 -> Parsed (Which CapDescriptor))
-> (IEId -> Word32) -> IEId -> Parsed (Which CapDescriptor)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEId -> Word32
ieWord (IEId -> Parsed (Which CapDescriptor))
-> STM IEId -> STM (Parsed (Which CapDescriptor))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conn -> Client' -> STM IEId
getConnExport Conn
targetConn Client'
client'
    PromiseClient{ TVar PromiseState
pState :: TVar PromiseState
$sel:pState:LocalClient :: Client' -> TVar PromiseState
pState } -> TVar PromiseState -> STM PromiseState
forall a. TVar a -> STM a
readTVar TVar PromiseState
pState STM PromiseState
-> (PromiseState -> STM (Parsed (Which CapDescriptor)))
-> STM (Parsed (Which CapDescriptor))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Pending { $sel:tmpDest:Ready :: PromiseState -> TmpDest
tmpDest = RemoteDest AnswerDest { Conn
conn :: Conn
$sel:conn:AnswerDest :: RemoteDest -> Conn
conn, PromisedAnswer
answer :: PromisedAnswer
$sel:answer:AnswerDest :: RemoteDest -> PromisedAnswer
answer } }
            | Conn
conn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
targetConn ->
                Parsed (Which CapDescriptor) -> STM (Parsed (Which CapDescriptor))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parsed (Which CapDescriptor)
 -> STM (Parsed (Which CapDescriptor)))
-> Parsed (Which CapDescriptor)
-> STM (Parsed (Which CapDescriptor))
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 } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
            if Conn
conn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
targetConn
                then Parsed (Which CapDescriptor) -> STM (Parsed (Which CapDescriptor))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parsed Word32 -> Parsed (Which CapDescriptor)
R.CapDescriptor'receiverHosted Word32
Parsed 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 } <- Cell ImportRef -> STM ImportRef
forall a. Cell a -> STM a
Fin.readCell Cell ImportRef
cell
        if Conn
hostConn Conn -> Conn -> Bool
forall a. Eq a => a -> a -> Bool
== Conn
targetConn
            then Parsed (Which CapDescriptor) -> STM (Parsed (Which CapDescriptor))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parsed Word32 -> Parsed (Which CapDescriptor)
R.CapDescriptor'receiverHosted (IEId -> Word32
ieWord IEId
importId))
            else Word32 -> Parsed (Which CapDescriptor)
Parsed Word32 -> Parsed (Which CapDescriptor)
R.CapDescriptor'senderHosted (Word32 -> Parsed (Which CapDescriptor))
-> (IEId -> Word32) -> IEId -> Parsed (Which CapDescriptor)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEId -> Word32
ieWord (IEId -> Parsed (Which CapDescriptor))
-> STM IEId -> STM (Parsed (Which CapDescriptor))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conn -> Client' -> STM IEId
getConnExport Conn
targetConn Client'
client'
  where
    newSenderPromise :: STM (Parsed (Which CapDescriptor))
newSenderPromise = Word32 -> Parsed (Which CapDescriptor)
Parsed Word32 -> Parsed (Which CapDescriptor)
R.CapDescriptor'senderPromise (Word32 -> Parsed (Which CapDescriptor))
-> (IEId -> Word32) -> IEId -> Parsed (Which CapDescriptor)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IEId -> Word32
ieWord (IEId -> Parsed (Which CapDescriptor))
-> STM IEId -> STM (Parsed (Which CapDescriptor))
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 <- Field 'Slot Payload (List CapDescriptor)
-> Raw Payload 'Const -> LimitT STM (Vector (Parsed CapDescriptor))
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 IsLabel "capTable" (Field 'Slot Payload (List CapDescriptor))
Field 'Slot Payload (List CapDescriptor)
#capTable Raw Payload 'Const
payload
    Vector Client
clients <- STM (Vector Client) -> LimitT STM (Vector Client)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM (Vector Client) -> LimitT STM (Vector Client))
-> STM (Vector Client) -> LimitT STM (Vector Client)
forall a b. (a -> b) -> a -> b
$ (Parsed CapDescriptor -> STM Client)
-> Vector (Parsed CapDescriptor) -> STM (Vector Client)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\R.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 <- Field 'Slot Payload (Maybe AnyPointer)
-> Raw Payload 'Const -> LimitT STM (Raw (Maybe AnyPointer) 'Const)
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 IsLabel "content" (Field 'Slot Payload (Maybe AnyPointer))
Field 'Slot Payload (Maybe AnyPointer)
#content Raw Payload 'Const
payload
    RawMPtr
content <- (Ptr 'Const -> LimitT STM (Ptr 'Const))
-> RawMPtr -> LimitT STM RawMPtr
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Message 'Const -> LimitT STM (Message 'Const))
-> Ptr 'Const -> LimitT STM (Ptr 'Const)
forall (f :: Mutability -> *) (m :: * -> *) (mutA :: Mutability)
       (mutB :: Mutability).
(TraverseMsg f, TraverseMsgCtx m mutA mutB) =>
(Message mutA -> m (Message mutB)) -> f mutA -> m (f mutB)
UntypedRaw.tMsg (Message 'Const -> LimitT STM (Message 'Const)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message 'Const -> LimitT STM (Message 'Const))
-> (Message 'Const -> Message 'Const)
-> Message 'Const
-> LimitT STM (Message 'Const)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Client -> Message 'Const -> Message 'Const
Message.withCapTable Vector Client
clients)) RawMPtr
Unwrapped (Untyped (ReprFor (Maybe AnyPointer)) 'Const)
rawContent
    Payload -> LimitT STM Payload
forall (f :: * -> *) a. Applicative f => a -> f a
pure Payload :: RawMPtr -> Vector (Parsed CapDescriptor) -> Payload
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 STM Conn' -> (Conn' -> STM Client) -> STM Client
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.CapDescriptor'none = Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Client' -> Client
Client Maybe Client'
forall a. Maybe a
Nothing)
    go conn' :: Conn'
conn'@Conn'{Map IEId EntryI
imports :: Map IEId EntryI
$sel:imports:Conn' :: Conn' -> Map IEId EntryI
imports} (R.CapDescriptor'senderHosted (IEId -> importId)) = do
        Maybe EntryI
entry <- IEId -> Map IEId EntryI -> STM (Maybe EntryI)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
M.lookup IEId
importId Map IEId EntryI
imports
        case Maybe EntryI
entry of
            Just EntryI{ $sel:promiseState:EntryI :: EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState=Just (TVar PromiseState, TmpDest)
_ } ->
                let imp :: Text
imp = String -> Text
forall a. IsString a => String -> a
fromString (IEId -> String
forall a. Show a => a -> String
show IEId
importId)
                in Conn' -> Parsed Exception -> STM Client
forall a. Conn' -> Parsed Exception -> STM a
abortConn Conn'
conn' (Parsed Exception -> STM Client) -> Parsed Exception -> STM Client
forall a b. (a -> b) -> a -> b
$ Text -> Parsed Exception
eFailed (Text -> Parsed Exception) -> Text -> Parsed Exception
forall a b. (a -> b) -> a -> b
$
                    Text
"received senderHosted capability #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
", but the imports table says #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is senderPromise."
            Just ent :: EntryI
ent@EntryI{ Rc ()
localRc :: Rc ()
$sel:localRc:EntryI :: EntryI -> Rc ()
localRc, Word32
remoteRc :: Word32
$sel:remoteRc:EntryI :: EntryI -> Word32
remoteRc, ExportMap
proxies :: ExportMap
$sel:proxies:EntryI :: EntryI -> ExportMap
proxies } -> do
                Rc () -> STM ()
forall a. Rc a -> STM ()
Rc.incr Rc ()
localRc
                EntryI -> IEId -> Map IEId EntryI -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
M.insert EntryI
ent { Rc ()
localRc :: Rc ()
$sel:localRc:EntryI :: Rc ()
localRc, $sel:remoteRc:EntryI :: Word32
remoteRc = Word32
remoteRc Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 } IEId
importId Map IEId EntryI
imports
                Cell ImportRef
cell <- ImportRef -> STM (Cell ImportRef)
forall (m :: * -> *) a. MonadSTM m => a -> m (Cell a)
Fin.newCell ImportRef :: Conn -> IEId -> ExportMap -> ImportRef
ImportRef
                    { Conn
conn :: Conn
$sel:conn:ImportRef :: Conn
conn
                    , IEId
importId :: IEId
$sel:importId:ImportRef :: IEId
importId
                    , ExportMap
proxies :: ExportMap
$sel:proxies:ImportRef :: ExportMap
proxies
                    }
                Conn' -> IO () -> STM ()
queueIO Conn'
conn' (IO () -> STM ()) -> IO () -> STM ()
forall a b. (a -> b) -> a -> b
$ Cell ImportRef -> IO () -> IO ()
forall a. Cell a -> IO () -> IO ()
Fin.addFinalizer Cell ImportRef
cell (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Rc () -> STM ()
forall a. Rc a -> STM ()
Rc.decr Rc ()
localRc
                Client -> STM Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client -> STM Client) -> Client -> STM Client
forall a b. (a -> b) -> a -> b
$ Maybe Client' -> Client
Client (Maybe Client' -> Client) -> Maybe Client' -> Client
forall a b. (a -> b) -> a -> b
$ Client' -> Maybe Client'
forall a. a -> Maybe a
Just (Client' -> Maybe Client') -> Client' -> Maybe Client'
forall a b. (a -> b) -> a -> b
$ Cell ImportRef -> Client'
ImportClient Cell ImportRef
cell

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

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

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

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


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