{-# 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
(
ConnConfig(..)
, handleConn
, Client
, call
, nullClient
, newPromiseClient
, IsClient(..)
, Pipeline
, walkPipelinePtr
, pipelineClient
, waitPipeline
, export
, clientMethodHandler
, unwrapServer
, waitClient
, RpcError(..)
) 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
type RawMPtr = Maybe (UntypedRaw.Ptr 'Const)
data RpcError
= ReceivedAbort (R.Parsed R.Exception)
| SentAbort (R.Parsed R.Exception)
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)
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
data Conn = Conn
{ Conn -> StableName (MVar ())
stableName :: StableName (MVar ())
, Conn -> Bool
debugMode :: !Bool
, 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)
, Conn' -> Supervisor
supervisor :: Supervisor
, Conn' -> IdPool
questionIdPool :: IdPool
, Conn' -> IdPool
exportIdPool :: IdPool
, 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 ())
, Conn' -> TQueue (IO ())
pendingCallbacks :: TQueue (IO ())
, Conn' -> Maybe Client
bootstrap :: Maybe Client
}
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
data ConnConfig = ConnConfig
{ ConnConfig -> Word32
maxQuestions :: !Word32
, ConnConfig -> Word32
maxExports :: !Word32
, ConnConfig -> Bool
debugMode :: !Bool
, ConnConfig -> Supervisor -> STM (Maybe Client)
getBootstrap :: Supervisor -> STM (Maybe Client)
, ConnConfig -> Maybe (Supervisor -> Client -> IO ())
withBootstrap :: Maybe (Supervisor -> Client -> IO ())
}
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
}
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
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' -> 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
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
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
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
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
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
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
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
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)
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 ()
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
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 ()
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
TVar LiveState -> LiveState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar LiveState
liveState LiveState
Dead
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')
newtype IdPool = IdPool (TVar [Word32])
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]
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
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]
:)
data EntryQA
= NewQA
{ EntryQA -> SnocList (Parsed Finish -> STM ())
onFinish :: SnocList (R.Parsed R.Finish -> STM ())
, EntryQA -> SnocList (Return -> STM ())
onReturn :: SnocList (Return -> STM ())
}
| HaveReturn
{ EntryQA -> Return
returnMsg :: Return
, onFinish :: SnocList (R.Parsed R.Finish -> STM ())
}
| HaveFinish
{ EntryQA -> Parsed Finish
finishMsg :: R.Parsed R.Finish
, onReturn :: SnocList (Return -> STM ())
}
data EntryI = EntryI
{ EntryI -> Rc ()
localRc :: Rc ()
, EntryI -> Word32
remoteRc :: !Word32
, EntryI -> ExportMap
proxies :: ExportMap
, EntryI -> Maybe (TVar PromiseState, TmpDest)
promiseState :: Maybe
( TVar PromiseState
, TmpDest
)
}
data EntryE = EntryE
{ EntryE -> Client'
client :: Client'
, EntryE -> Word32
refCount :: !Word32
}
class IsClient a where
toClient :: a -> Client
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 -})"
newtype Client =
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)
data Client'
= LocalClient
{ Client' -> ExportMap
exportMap :: ExportMap
, Client' -> Rc (CallInfo -> STM ())
qCall :: Rc (Server.CallInfo -> STM ())
, Client' -> Cell ()
finalizerKey :: Fin.Cell ()
, Client' -> forall a. Typeable a => Maybe a
unwrapper :: forall a. Typeable a => Maybe a
}
| PromiseClient
{ Client' -> TVar PromiseState
pState :: TVar PromiseState
, exportMap :: ExportMap
, Client' -> TmpDest
origTarget :: TmpDest
}
| ImportClient (Fin.Cell ImportRef)
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)
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 }
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
(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)
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
data PromiseState
= Ready
{ PromiseState -> Client
target :: Client
}
| Embargo
{ PromiseState -> TQueue CallInfo
callBuffer :: TQueue Server.CallInfo
}
| Pending
{ PromiseState -> TmpDest
tmpDest :: TmpDest
}
| Error (R.Parsed R.Exception)
data TmpDest
= LocalDest LocalDest
| RemoteDest RemoteDest
newtype LocalDest
= LocalBuffer { LocalDest -> TQueue CallInfo
callBuffer :: TQueue Server.CallInfo }
data RemoteDest
= AnswerDest
{ RemoteDest -> Conn
conn :: Conn
, RemoteDest -> PromisedAnswer
answer :: PromisedAnswer
}
| ImportDest (Fin.Cell ImportRef)
data ImportRef = ImportRef
{ ImportRef -> Conn
conn :: Conn
, ImportRef -> IEId
importId :: !IEId
, ImportRef -> ExportMap
proxies :: ExportMap
}
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
newtype ExportMap = ExportMap (M.Map Conn IEId)
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)
}
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
_ ->
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')
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
}
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 }
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 ->
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 ->
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
_ ->
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."
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)
nullClient :: Client
nullClient :: Client
nullClient = Maybe Client' -> Client
Client Maybe Client'
forall a. Maybe a
Nothing
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)
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
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
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
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
[] -> 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
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 :: 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 :: 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
coordinator :: Conn -> IO ()
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
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 _ ->
() -> 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
, $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
, $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
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
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
}
}
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
}
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 ->
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
_ ->
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."
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 ->
case Parsed (Which Resolve)
union' of
R.Resolve'cap R.CapDescriptor{union' = R.CapDescriptor'receiverHosted importId} ->
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
}
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 } ->
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
]
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 :: (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
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))
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
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
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
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
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)
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
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)
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
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 ()
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
}
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
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"
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
( 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 ) ->
RemoteDest -> STM ()
disembargoAndResolve RemoteDest
dest
( Maybe Client'
_, LocalDest LocalBuffer { TQueue CallInfo
callBuffer :: TQueue CallInfo
$sel:callBuffer:LocalBuffer :: LocalDest -> TQueue CallInfo
callBuffer } ) ->
TQueue CallInfo -> STM ()
flushAndResolve TQueue CallInfo
callBuffer
( 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)
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
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)
}
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
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 ->
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
_ ->
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."
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
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
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 }
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 :: 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 _) =
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)
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
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
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
}