{-# LANGUAGE OverloadedStrings #-}
module Network.GRPC.Server.Call (
Call(..)
, setupCall
, recvInput
, sendOutput
, sendGrpcException
, getRequestMetadata
, setResponseInitialMetadata
, sendNextOutput
, sendFinalOutput
, sendTrailers
, recvNextInput
, recvFinalInput
, recvEndOfInput
, initiateResponse
, sendTrailersOnly
, recvNextInputElem
, recvInputWithMeta
, sendOutputWithMeta
, getRequestHeaders
, sendProperTrailers
, serverExceptionToClientError
, HandlerTerminated(..)
, ResponseAlreadyInitiated(..)
) where
import Control.Concurrent.STM
import Control.Exception (throwIO)
import Control.Monad
import Control.Monad.Catch
import Data.Bitraversable
import Data.List.NonEmpty (NonEmpty)
import Data.Void
import GHC.Stack
import Network.HTTP.Types qualified as HTTP
import Network.HTTP2.Server qualified as HTTP2
import Network.GRPC.Common
import Network.GRPC.Common.Compression qualified as Compr
import Network.GRPC.Common.Headers
import Network.GRPC.Common.StreamElem qualified as StreamElem
import Network.GRPC.Server.Context
import Network.GRPC.Server.Session
import Network.GRPC.Spec
import Network.GRPC.Spec.Serialization
import Network.GRPC.Util.HTTP2 (fromHeaderTable)
import Network.GRPC.Util.Session qualified as Session
import Network.GRPC.Util.Session.Server qualified as Server
data Call rpc = SupportsServerRpc rpc => Call {
forall {k} (rpc :: k). Call rpc -> ServerContext
callContext :: ServerContext
, forall {k} (rpc :: k). Call rpc -> ServerSession rpc
callSession :: ServerSession rpc
, forall {k} (rpc :: k). Call rpc -> Channel (ServerSession rpc)
callChannel :: Session.Channel (ServerSession rpc)
, :: RequestHeaders' HandledSynthesized
, forall {k} (rpc :: k). Call rpc -> TVar (CallInitialMetadata rpc)
callResponseMetadata :: TVar (CallInitialMetadata rpc)
, forall {k} (rpc :: k). Call rpc -> TMVar Kickoff
callResponseKickoff :: TMVar Kickoff
}
data CallInitialMetadata rpc =
CallInitialMetadataNotSet
| CallInitialMetadataSet (ResponseInitialMetadata rpc) CallStack
deriving stock instance IsRPC rpc => Show (CallInitialMetadata rpc)
data Kickoff =
KickoffRegular CallStack
| KickoffTrailersOnly CallStack TrailersOnly
deriving (Int -> Kickoff -> ShowS
[Kickoff] -> ShowS
Kickoff -> String
(Int -> Kickoff -> ShowS)
-> (Kickoff -> String) -> ([Kickoff] -> ShowS) -> Show Kickoff
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Kickoff -> ShowS
showsPrec :: Int -> Kickoff -> ShowS
$cshow :: Kickoff -> String
show :: Kickoff -> String
$cshowList :: [Kickoff] -> ShowS
showList :: [Kickoff] -> ShowS
Show)
kickoffCallStack :: Kickoff -> CallStack
kickoffCallStack :: Kickoff -> CallStack
kickoffCallStack (KickoffRegular CallStack
cs ) = CallStack
cs
kickoffCallStack (KickoffTrailersOnly CallStack
cs TrailersOnly
_) = CallStack
cs
setupCall :: forall rpc.
SupportsServerRpc rpc
=> Server.ConnectionToClient
-> ServerContext
-> IO (Call rpc, Maybe Timeout)
setupCall :: forall {k} (rpc :: k).
SupportsServerRpc rpc =>
ConnectionToClient -> ServerContext -> IO (Call rpc, Maybe Timeout)
setupCall ConnectionToClient
conn callContext :: ServerContext
callContext@ServerContext{ServerParams
serverParams :: ServerParams
serverParams :: ServerContext -> ServerParams
serverParams} = do
callResponseMetadata <- CallInitialMetadata rpc -> IO (TVar (CallInitialMetadata rpc))
forall a. a -> IO (TVar a)
newTVarIO CallInitialMetadata rpc
forall {k} (rpc :: k). CallInitialMetadata rpc
CallInitialMetadataNotSet
callResponseKickoff <- newEmptyTMVarIO
(inboundHeaders, timeout) <- determineInbound callSession req
let callRequestHeaders = Headers (ServerInbound rpc) -> RequestHeaders' HandledSynthesized
forall k (rpc :: k).
Headers (ServerInbound rpc) -> RequestHeaders' HandledSynthesized
inbHeaders Headers (ServerInbound rpc)
inboundHeaders
let cOut = ServerSession rpc
-> Either
(InvalidHeaders HandledSynthesized)
(Maybe (NonEmpty CompressionId))
-> Compression
forall {k} (rpc :: k).
ServerSession rpc
-> Either
(InvalidHeaders HandledSynthesized)
(Maybe (NonEmpty CompressionId))
-> Compression
getOutboundCompression ServerSession rpc
callSession (Either
(InvalidHeaders HandledSynthesized)
(Maybe (NonEmpty CompressionId))
-> Compression)
-> Either
(InvalidHeaders HandledSynthesized)
(Maybe (NonEmpty CompressionId))
-> Compression
forall a b. (a -> b) -> a -> b
$
RequestHeaders' HandledSynthesized
-> HKD
(Checked (InvalidHeaders HandledSynthesized))
(Maybe (NonEmpty CompressionId))
forall (f :: * -> *).
RequestHeaders_ f -> HKD f (Maybe (NonEmpty CompressionId))
requestAcceptCompression RequestHeaders' HandledSynthesized
callRequestHeaders
callChannel :: Session.Channel (ServerSession rpc) <-
Session.setupResponseChannel
callSession
conn
(Session.FlowStartRegular inboundHeaders)
( startOutbound
serverParams
callResponseMetadata
callResponseKickoff
cOut
)
return (
Call{
callContext
, callSession
, callRequestHeaders
, callResponseMetadata
, callResponseKickoff
, callChannel
}
, timeout
)
where
callSession :: ServerSession rpc
callSession :: ServerSession rpc
callSession = ServerSession {
serverSessionContext :: ServerContext
serverSessionContext = ServerContext
callContext
}
req :: HTTP2.Request
req :: Request
req = ConnectionToClient -> Request
Server.request ConnectionToClient
conn
determineInbound :: forall rpc.
SupportsServerRpc rpc
=> ServerSession rpc
-> HTTP2.Request
-> IO (Headers (ServerInbound rpc), Maybe Timeout)
determineInbound :: forall {k} (rpc :: k).
SupportsServerRpc rpc =>
ServerSession rpc
-> Request -> IO (Headers (ServerInbound rpc), Maybe Timeout)
determineInbound ServerSession rpc
session Request
req = do
requestHeaders' <- (forall a. GrpcException -> IO a)
-> RequestHeaders_ (Checked (InvalidHeaders GrpcException))
-> IO (RequestHeaders' HandledSynthesized)
forall (h :: (* -> *) -> *) (m :: * -> *).
(Traversable h, Monad m) =>
(forall a. GrpcException -> m a)
-> h (Checked (InvalidHeaders GrpcException))
-> m (h (Checked (InvalidHeaders HandledSynthesized)))
throwSynthesized GrpcException -> IO a
forall a. GrpcException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO RequestHeaders_ (Checked (InvalidHeaders GrpcException))
parsed
case verifyAllIf serverVerifyHeaders requestHeaders' of
Left InvalidHeaders HandledSynthesized
err -> CallSetupFailure -> IO (Headers (ServerInbound rpc), Maybe Timeout)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CallSetupFailure
-> IO (Headers (ServerInbound rpc), Maybe Timeout))
-> CallSetupFailure
-> IO (Headers (ServerInbound rpc), Maybe Timeout)
forall a b. (a -> b) -> a -> b
$ InvalidHeaders HandledSynthesized -> CallSetupFailure
CallSetupInvalidRequestHeaders InvalidHeaders HandledSynthesized
err
Right RequiredHeaders RequestHeaders_
hdrs -> do
cIn <- ServerSession rpc -> Maybe CompressionId -> IO Compression
forall {k} (rpc :: k).
ServerSession rpc -> Maybe CompressionId -> IO Compression
getInboundCompression ServerSession rpc
session (RequiredHeaders RequestHeaders_ -> Maybe CompressionId
requiredRequestCompression RequiredHeaders RequestHeaders_
hdrs)
return (
InboundHeaders {
inbHeaders = requestHeaders'
, inbCompression = cIn
}
, requiredRequestTimeout hdrs
)
where
ServerSession{ServerContext
serverSessionContext :: forall {k} (rpc :: k). ServerSession rpc -> ServerContext
serverSessionContext :: ServerContext
serverSessionContext} = ServerSession rpc
session
ServerContext{ServerParams
serverParams :: ServerContext -> ServerParams
serverParams :: ServerParams
serverParams} = ServerContext
serverSessionContext
ServerParams{Bool
serverVerifyHeaders :: Bool
serverVerifyHeaders :: ServerParams -> Bool
serverVerifyHeaders} = ServerParams
serverParams
parsed :: RequestHeaders' GrpcException
parsed :: RequestHeaders_ (Checked (InvalidHeaders GrpcException))
parsed = Proxy rpc
-> [Header]
-> RequestHeaders_ (Checked (InvalidHeaders GrpcException))
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc
-> [Header]
-> RequestHeaders_ (Checked (InvalidHeaders GrpcException))
parseRequestHeaders' (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @rpc) ([Header]
-> RequestHeaders_ (Checked (InvalidHeaders GrpcException)))
-> [Header]
-> RequestHeaders_ (Checked (InvalidHeaders GrpcException))
forall a b. (a -> b) -> a -> b
$
TokenHeaderTable -> [Header]
fromHeaderTable (TokenHeaderTable -> [Header]) -> TokenHeaderTable -> [Header]
forall a b. (a -> b) -> a -> b
$ Request -> TokenHeaderTable
HTTP2.requestHeaders Request
req
startOutbound :: forall rpc.
SupportsServerRpc rpc
=> ServerParams
-> TVar (CallInitialMetadata rpc)
-> TMVar Kickoff
-> Compression
-> IO (Session.FlowStart (ServerOutbound rpc), Session.ResponseInfo)
startOutbound :: forall {k} (rpc :: k).
SupportsServerRpc rpc =>
ServerParams
-> TVar (CallInitialMetadata rpc)
-> TMVar Kickoff
-> Compression
-> IO (FlowStart (ServerOutbound rpc), ResponseInfo)
startOutbound ServerParams
serverParams TVar (CallInitialMetadata rpc)
metadataVar TMVar Kickoff
kickoffVar Compression
cOut = do
kickoff <- STM Kickoff -> IO Kickoff
forall a. STM a -> IO a
atomically (STM Kickoff -> IO Kickoff) -> STM Kickoff -> IO Kickoff
forall a b. (a -> b) -> a -> b
$ TMVar Kickoff -> STM Kickoff
forall a. TMVar a -> STM a
readTMVar TMVar Kickoff
kickoffVar
flowStart :: Session.FlowStart (ServerOutbound rpc) <-
case kickoff of
KickoffRegular CallStack
_cs -> do
responseMetadata <- do
mMetadata <- STM (CallInitialMetadata rpc) -> IO (CallInitialMetadata rpc)
forall a. STM a -> IO a
atomically (STM (CallInitialMetadata rpc) -> IO (CallInitialMetadata rpc))
-> STM (CallInitialMetadata rpc) -> IO (CallInitialMetadata rpc)
forall a b. (a -> b) -> a -> b
$ TVar (CallInitialMetadata rpc) -> STM (CallInitialMetadata rpc)
forall a. TVar a -> STM a
readTVar TVar (CallInitialMetadata rpc)
metadataVar
case mMetadata of
CallInitialMetadataSet ResponseInitialMetadata rpc
md CallStack
_cs -> ResponseInitialMetadata rpc -> IO [CustomMetadata]
forall a. BuildMetadata a => a -> IO [CustomMetadata]
buildMetadataIO ResponseInitialMetadata rpc
md
CallInitialMetadata rpc
CallInitialMetadataNotSet -> ResponseInitialMetadataNotSet -> IO [CustomMetadata]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ResponseInitialMetadataNotSet -> IO [CustomMetadata])
-> ResponseInitialMetadataNotSet -> IO [CustomMetadata]
forall a b. (a -> b) -> a -> b
$ ResponseInitialMetadataNotSet
ResponseInitialMetadataNotSet
return $ Session.FlowStartRegular $ OutboundHeaders {
outHeaders = ResponseHeaders {
responseCompression =
Just $ Compr.compressionId cOut
, responseAcceptCompression =
Just $ Compr.offer compr
, responseContentType =
serverContentType serverParams
, responseMetadata =
customMetadataMapFromList responseMetadata
, responseUnrecognized =
()
}
, outCompression = cOut
}
KickoffTrailersOnly CallStack
_cs TrailersOnly
trailers ->
FlowStart (ServerOutbound rpc)
-> IO (FlowStart (ServerOutbound rpc))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FlowStart (ServerOutbound rpc)
-> IO (FlowStart (ServerOutbound rpc)))
-> FlowStart (ServerOutbound rpc)
-> IO (FlowStart (ServerOutbound rpc))
forall a b. (a -> b) -> a -> b
$ NoMessages (ServerOutbound rpc) -> FlowStart (ServerOutbound rpc)
forall {k} (flow :: k). NoMessages flow -> FlowStart flow
Session.FlowStartNoMessages TrailersOnly
NoMessages (ServerOutbound rpc)
trailers
return (flowStart, buildResponseInfo flowStart)
where
compr :: Compr.Negotation
compr :: Negotation
compr = ServerParams -> Negotation
serverCompression ServerParams
serverParams
buildResponseInfo ::
Session.FlowStart (ServerOutbound rpc)
-> Session.ResponseInfo
buildResponseInfo :: FlowStart (ServerOutbound rpc) -> ResponseInfo
buildResponseInfo FlowStart (ServerOutbound rpc)
start = Session.ResponseInfo {
responseStatus :: Status
responseStatus = Status
HTTP.ok200
, responseHeaders :: [Header]
responseHeaders =
case FlowStart (ServerOutbound rpc)
start of
Session.FlowStartRegular Headers (ServerOutbound rpc)
headers ->
Proxy rpc -> ResponseHeaders -> [Header]
forall {k} (rpc :: k).
SupportsServerRpc rpc =>
Proxy rpc -> ResponseHeaders -> [Header]
buildResponseHeaders
(forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @rpc)
(Headers (ServerOutbound rpc) -> ResponseHeaders
forall k (rpc :: k).
Headers (ServerOutbound rpc) -> ResponseHeaders
outHeaders Headers (ServerOutbound rpc)
headers)
Session.FlowStartNoMessages NoMessages (ServerOutbound rpc)
trailers ->
(ContentType -> Maybe ByteString) -> TrailersOnly -> [Header]
buildTrailersOnly
(ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (ContentType -> ByteString) -> ContentType -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy rpc -> ContentType -> ByteString
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> ContentType -> ByteString
chooseContentType (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @rpc))
TrailersOnly
NoMessages (ServerOutbound rpc)
trailers
, responseBody :: Maybe ByteString
responseBody = Maybe ByteString
forall a. Maybe a
Nothing
}
getInboundCompression ::
ServerSession rpc
-> Maybe CompressionId
-> IO Compression
getInboundCompression :: forall {k} (rpc :: k).
ServerSession rpc -> Maybe CompressionId -> IO Compression
getInboundCompression ServerSession rpc
session = \case
Maybe CompressionId
Nothing -> Compression -> IO Compression
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Compression
noCompression
Just CompressionId
cid ->
case Negotation -> CompressionId -> Maybe Compression
Compr.getSupported Negotation
serverCompression CompressionId
cid of
Just Compression
compr -> Compression -> IO Compression
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Compression
compr
Maybe Compression
Nothing -> CallSetupFailure -> IO Compression
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CallSetupFailure -> IO Compression)
-> CallSetupFailure -> IO Compression
forall a b. (a -> b) -> a -> b
$ CompressionId -> CallSetupFailure
CallSetupUnsupportedCompression CompressionId
cid
where
ServerSession{ServerContext
serverSessionContext :: forall {k} (rpc :: k). ServerSession rpc -> ServerContext
serverSessionContext :: ServerContext
serverSessionContext} = ServerSession rpc
session
ServerContext{ServerParams
serverParams :: ServerContext -> ServerParams
serverParams :: ServerParams
serverParams} = ServerContext
serverSessionContext
ServerParams{Negotation
serverCompression :: ServerParams -> Negotation
serverCompression :: Negotation
serverCompression} = ServerParams
serverParams
getOutboundCompression ::
ServerSession rpc
-> Either (InvalidHeaders HandledSynthesized) (Maybe (NonEmpty CompressionId))
-> Compression
getOutboundCompression :: forall {k} (rpc :: k).
ServerSession rpc
-> Either
(InvalidHeaders HandledSynthesized)
(Maybe (NonEmpty CompressionId))
-> Compression
getOutboundCompression ServerSession rpc
session = \case
Left InvalidHeaders HandledSynthesized
_invalidHeader -> Compression
noCompression
Right Maybe (NonEmpty CompressionId)
Nothing -> Compression
noCompression
Right (Just NonEmpty CompressionId
cids) -> Negotation -> NonEmpty CompressionId -> Compression
Compr.choose Negotation
serverCompression NonEmpty CompressionId
cids
where
ServerSession{ServerContext
serverSessionContext :: forall {k} (rpc :: k). ServerSession rpc -> ServerContext
serverSessionContext :: ServerContext
serverSessionContext} = ServerSession rpc
session
ServerContext{ServerParams
serverParams :: ServerContext -> ServerParams
serverParams :: ServerParams
serverParams} = ServerContext
serverSessionContext
ServerParams{Negotation
serverCompression :: ServerParams -> Negotation
serverCompression :: Negotation
serverCompression} = ServerParams
serverParams
serverExceptionToClientError :: ServerParams -> SomeException -> IO ProperTrailers
serverExceptionToClientError :: ServerParams -> SomeException -> IO ProperTrailers
serverExceptionToClientError ServerParams
params SomeException
err
| Just (GrpcException
err' :: GrpcException) <- SomeException -> Maybe GrpcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err =
ProperTrailers -> IO ProperTrailers
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProperTrailers -> IO ProperTrailers)
-> ProperTrailers -> IO ProperTrailers
forall a b. (a -> b) -> a -> b
$ GrpcException -> ProperTrailers
grpcExceptionToTrailers GrpcException
err'
| Bool
otherwise = do
mMsg <- ServerParams -> SomeException -> IO (Maybe Text)
serverExceptionToClient ServerParams
params SomeException
err
return $ simpleProperTrailers (GrpcError GrpcUnknown) mMsg Nothing mempty
recvInput :: HasCallStack => Call rpc -> IO (StreamElem NoMetadata (Input rpc))
recvInput :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (StreamElem NoMetadata (Input rpc))
recvInput = (StreamElem NoMetadata (InboundMeta, Input rpc)
-> StreamElem NoMetadata (Input rpc))
-> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
-> IO (StreamElem NoMetadata (Input rpc))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((InboundMeta, Input rpc) -> Input rpc)
-> StreamElem NoMetadata (InboundMeta, Input rpc)
-> StreamElem NoMetadata (Input rpc)
forall a b.
(a -> b) -> StreamElem NoMetadata a -> StreamElem NoMetadata b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InboundMeta, Input rpc) -> Input rpc
forall a b. (a, b) -> b
snd) (IO (StreamElem NoMetadata (InboundMeta, Input rpc))
-> IO (StreamElem NoMetadata (Input rpc)))
-> (Call rpc
-> IO (StreamElem NoMetadata (InboundMeta, Input rpc)))
-> Call rpc
-> IO (StreamElem NoMetadata (Input rpc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Call rpc -> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
recvInputWithMeta
recvNextInputElem :: HasCallStack => Call rpc -> IO (NextElem (Input rpc))
recvNextInputElem :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (NextElem (Input rpc))
recvNextInputElem = (NextElem (InboundMeta, Input rpc) -> NextElem (Input rpc))
-> IO (NextElem (InboundMeta, Input rpc))
-> IO (NextElem (Input rpc))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((InboundMeta, Input rpc) -> Input rpc)
-> NextElem (InboundMeta, Input rpc) -> NextElem (Input rpc)
forall a b. (a -> b) -> NextElem a -> NextElem b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InboundMeta, Input rpc) -> Input rpc
forall a b. (a, b) -> b
snd) (IO (NextElem (InboundMeta, Input rpc))
-> IO (NextElem (Input rpc)))
-> (Call rpc -> IO (NextElem (InboundMeta, Input rpc)))
-> Call rpc
-> IO (NextElem (Input rpc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Call rpc -> IO (NextElem (InboundMeta, Input rpc))
forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (NextElem (InboundMeta, Input rpc))
recvEither
recvInputWithMeta :: forall rpc.
HasCallStack
=> Call rpc
-> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
recvInputWithMeta :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
recvInputWithMeta = Call rpc -> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
recvBoth
sendOutput ::
HasCallStack
=> Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ()
sendOutput :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ()
sendOutput Call rpc
call = Call rpc
-> StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
-> IO ()
forall {k} (rpc :: k).
HasCallStack =>
Call rpc
-> StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
-> IO ()
sendOutputWithMeta Call rpc
call (StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
-> IO ())
-> (StreamElem (ResponseTrailingMetadata rpc) (Output rpc)
-> StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc))
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Output rpc -> (OutboundMeta, Output rpc))
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc)
-> StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
forall a b.
(a -> b)
-> StreamElem (ResponseTrailingMetadata rpc) a
-> StreamElem (ResponseTrailingMetadata rpc) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OutboundMeta
forall a. Default a => a
def,)
sendOutputWithMeta :: forall rpc.
HasCallStack
=> Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
-> IO ()
sendOutputWithMeta :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc
-> StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
-> IO ()
sendOutputWithMeta call :: Call rpc
call@Call{Channel (ServerSession rpc)
callChannel :: forall {k} (rpc :: k). Call rpc -> Channel (ServerSession rpc)
callChannel :: Channel (ServerSession rpc)
callChannel} StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
msg = do
Call rpc -> IO ()
forall {k} (rpc :: k). HasCallStack => Call rpc -> IO ()
initiateResponse Call rpc
call
msg' <- (ResponseTrailingMetadata rpc -> IO ProperTrailers)
-> ((OutboundMeta, Output rpc) -> IO (OutboundMeta, Output rpc))
-> StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
-> IO (StreamElem ProperTrailers (OutboundMeta, Output rpc))
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> StreamElem a b -> f (StreamElem c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ResponseTrailingMetadata rpc -> IO ProperTrailers
mkTrailers (OutboundMeta, Output rpc) -> IO (OutboundMeta, Output rpc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamElem
(ResponseTrailingMetadata rpc) (OutboundMeta, Output rpc)
msg
Session.send callChannel msg'
StreamElem.whenDefinitelyFinal msg $ \ResponseTrailingMetadata rpc
_ ->
Channel (ServerSession rpc) -> IO ()
forall sess. Channel sess -> IO ()
Session.waitForOutbound Channel (ServerSession rpc)
callChannel
where
mkTrailers :: ResponseTrailingMetadata rpc -> IO ProperTrailers
mkTrailers :: ResponseTrailingMetadata rpc -> IO ProperTrailers
mkTrailers ResponseTrailingMetadata rpc
metadata = do
metadata' <- [CustomMetadata] -> CustomMetadataMap
customMetadataMapFromList ([CustomMetadata] -> CustomMetadataMap)
-> IO [CustomMetadata] -> IO CustomMetadataMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponseTrailingMetadata rpc -> IO [CustomMetadata]
forall a. BuildMetadata a => a -> IO [CustomMetadata]
buildMetadataIO ResponseTrailingMetadata rpc
metadata
return $ simpleProperTrailers GrpcOk Nothing Nothing metadata'
sendGrpcException :: Call rpc -> GrpcException -> IO ()
sendGrpcException :: forall {k} (rpc :: k). Call rpc -> GrpcException -> IO ()
sendGrpcException Call rpc
call = Call rpc -> ProperTrailers -> IO ()
forall {k} (rpc :: k). Call rpc -> ProperTrailers -> IO ()
sendProperTrailers Call rpc
call (ProperTrailers -> IO ())
-> (GrpcException -> ProperTrailers) -> GrpcException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GrpcException -> ProperTrailers
grpcExceptionToTrailers
getRequestMetadata :: Call rpc -> IO (RequestMetadata rpc)
getRequestMetadata :: forall {k} (rpc :: k). Call rpc -> IO (RequestMetadata rpc)
getRequestMetadata Call{RequestHeaders' HandledSynthesized
callRequestHeaders :: forall {k} (rpc :: k).
Call rpc -> RequestHeaders' HandledSynthesized
callRequestHeaders :: RequestHeaders' HandledSynthesized
callRequestHeaders} =
[CustomMetadata] -> IO (RequestMetadata rpc)
forall a (m :: * -> *).
(ParseMetadata a, MonadThrow m) =>
[CustomMetadata] -> m a
forall (m :: * -> *).
MonadThrow m =>
[CustomMetadata] -> m (RequestMetadata rpc)
parseMetadata ([CustomMetadata] -> IO (RequestMetadata rpc))
-> (CustomMetadataMap -> [CustomMetadata])
-> CustomMetadataMap
-> IO (RequestMetadata rpc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CustomMetadataMap -> [CustomMetadata]
customMetadataMapToList (CustomMetadataMap -> IO (RequestMetadata rpc))
-> CustomMetadataMap -> IO (RequestMetadata rpc)
forall a b. (a -> b) -> a -> b
$
RequestHeaders' HandledSynthesized -> CustomMetadataMap
forall (f :: * -> *). RequestHeaders_ f -> CustomMetadataMap
requestMetadata RequestHeaders' HandledSynthesized
callRequestHeaders
setResponseInitialMetadata ::
HasCallStack
=> Call rpc -> ResponseInitialMetadata rpc -> IO ()
setResponseInitialMetadata :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> ResponseInitialMetadata rpc -> IO ()
setResponseInitialMetadata Call{ TVar (CallInitialMetadata rpc)
callResponseMetadata :: forall {k} (rpc :: k). Call rpc -> TVar (CallInitialMetadata rpc)
callResponseMetadata :: TVar (CallInitialMetadata rpc)
callResponseMetadata
, TMVar Kickoff
callResponseKickoff :: forall {k} (rpc :: k). Call rpc -> TMVar Kickoff
callResponseKickoff :: TMVar Kickoff
callResponseKickoff
}
ResponseInitialMetadata rpc
md = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
mKickoff <- (Kickoff -> CallStack) -> Maybe Kickoff -> Maybe CallStack
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Kickoff -> CallStack
kickoffCallStack (Maybe Kickoff -> Maybe CallStack)
-> STM (Maybe Kickoff) -> STM (Maybe CallStack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar Kickoff -> STM (Maybe Kickoff)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar Kickoff
callResponseKickoff
case mKickoff of
Maybe CallStack
Nothing ->
TVar (CallInitialMetadata rpc) -> CallInitialMetadata rpc -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (CallInitialMetadata rpc)
callResponseMetadata (ResponseInitialMetadata rpc -> CallStack -> CallInitialMetadata rpc
forall {k} (rpc :: k).
ResponseInitialMetadata rpc -> CallStack -> CallInitialMetadata rpc
CallInitialMetadataSet ResponseInitialMetadata rpc
md CallStack
HasCallStack => CallStack
callStack)
Just CallStack
cs ->
ResponseAlreadyInitiated -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (ResponseAlreadyInitiated -> STM ())
-> ResponseAlreadyInitiated -> STM ()
forall a b. (a -> b) -> a -> b
$ CallStack -> CallStack -> ResponseAlreadyInitiated
ResponseAlreadyInitiated CallStack
cs CallStack
HasCallStack => CallStack
callStack
initiateResponse :: HasCallStack => Call rpc -> IO ()
initiateResponse :: forall {k} (rpc :: k). HasCallStack => Call rpc -> IO ()
initiateResponse Call{TMVar Kickoff
callResponseKickoff :: forall {k} (rpc :: k). Call rpc -> TMVar Kickoff
callResponseKickoff :: TMVar Kickoff
callResponseKickoff} = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar Kickoff -> Kickoff -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar Kickoff
callResponseKickoff (Kickoff -> STM Bool) -> Kickoff -> STM Bool
forall a b. (a -> b) -> a -> b
$ CallStack -> Kickoff
KickoffRegular CallStack
HasCallStack => CallStack
callStack
sendTrailersOnly ::
HasCallStack
=> Call rpc -> ResponseTrailingMetadata rpc -> IO ()
sendTrailersOnly :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> ResponseTrailingMetadata rpc -> IO ()
sendTrailersOnly Call{ServerContext
callContext :: forall {k} (rpc :: k). Call rpc -> ServerContext
callContext :: ServerContext
callContext, TMVar Kickoff
callResponseKickoff :: forall {k} (rpc :: k). Call rpc -> TMVar Kickoff
callResponseKickoff :: TMVar Kickoff
callResponseKickoff} ResponseTrailingMetadata rpc
metadata = do
metadata' <- ResponseTrailingMetadata rpc -> IO [CustomMetadata]
forall a. BuildMetadata a => a -> IO [CustomMetadata]
buildMetadataIO ResponseTrailingMetadata rpc
metadata
atomically $ do
previously <- fmap kickoffCallStack <$> tryReadTMVar callResponseKickoff
case previously of
Maybe CallStack
Nothing -> TMVar Kickoff -> Kickoff -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Kickoff
callResponseKickoff (Kickoff -> STM ()) -> Kickoff -> STM ()
forall a b. (a -> b) -> a -> b
$
CallStack -> TrailersOnly -> Kickoff
KickoffTrailersOnly CallStack
HasCallStack => CallStack
callStack ([CustomMetadata] -> TrailersOnly
trailers [CustomMetadata]
metadata')
Just CallStack
cs -> ResponseAlreadyInitiated -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (ResponseAlreadyInitiated -> STM ())
-> ResponseAlreadyInitiated -> STM ()
forall a b. (a -> b) -> a -> b
$ CallStack -> CallStack -> ResponseAlreadyInitiated
ResponseAlreadyInitiated CallStack
cs CallStack
HasCallStack => CallStack
callStack
where
ServerContext{ServerParams
serverParams :: ServerContext -> ServerParams
serverParams :: ServerParams
serverParams} = ServerContext
callContext
trailers :: [CustomMetadata] -> TrailersOnly
trailers :: [CustomMetadata] -> TrailersOnly
trailers [CustomMetadata]
metadata' = TrailersOnly {
trailersOnlyContentType :: HKD Undecorated (Maybe ContentType)
trailersOnlyContentType =
ServerParams -> Maybe ContentType
serverContentType ServerParams
serverParams
, trailersOnlyProper :: ProperTrailers
trailersOnlyProper =
HKD Undecorated GrpcStatus
-> HKD Undecorated (Maybe Text)
-> HKD Undecorated (Maybe ByteString)
-> CustomMetadataMap
-> ProperTrailers
forall (f :: * -> *).
ValidDecoration Applicative f =>
HKD f GrpcStatus
-> HKD f (Maybe Text)
-> HKD f (Maybe ByteString)
-> CustomMetadataMap
-> ProperTrailers_ f
simpleProperTrailers GrpcStatus
HKD Undecorated GrpcStatus
GrpcOk Maybe Text
HKD Undecorated (Maybe Text)
forall a. Maybe a
Nothing Maybe ByteString
HKD Undecorated (Maybe ByteString)
forall a. Maybe a
Nothing (CustomMetadataMap -> ProperTrailers)
-> CustomMetadataMap -> ProperTrailers
forall a b. (a -> b) -> a -> b
$
[CustomMetadata] -> CustomMetadataMap
customMetadataMapFromList [CustomMetadata]
metadata'
}
getRequestHeaders :: Call rpc -> IO (RequestHeaders' HandledSynthesized)
Call{RequestHeaders' HandledSynthesized
callRequestHeaders :: forall {k} (rpc :: k).
Call rpc -> RequestHeaders' HandledSynthesized
callRequestHeaders :: RequestHeaders' HandledSynthesized
callRequestHeaders} =
RequestHeaders' HandledSynthesized
-> IO (RequestHeaders' HandledSynthesized)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RequestHeaders' HandledSynthesized
callRequestHeaders
sendNextOutput ::
HasCallStack
=> Call rpc -> Output rpc -> IO ()
sendNextOutput :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> Output rpc -> IO ()
sendNextOutput Call rpc
call = Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ()
forall {k} (rpc :: k).
HasCallStack =>
Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ()
sendOutput Call rpc
call (StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ())
-> (Output rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc))
-> Output rpc
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Output rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc)
forall b a. a -> StreamElem b a
StreamElem
sendFinalOutput ::
HasCallStack
=> Call rpc -> (Output rpc, ResponseTrailingMetadata rpc) -> IO ()
sendFinalOutput :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> (Output rpc, ResponseTrailingMetadata rpc) -> IO ()
sendFinalOutput Call rpc
call = Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ()
forall {k} (rpc :: k).
HasCallStack =>
Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ()
sendOutput Call rpc
call (StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ())
-> ((Output rpc, ResponseTrailingMetadata rpc)
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc))
-> (Output rpc, ResponseTrailingMetadata rpc)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Output rpc
-> ResponseTrailingMetadata rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc))
-> (Output rpc, ResponseTrailingMetadata rpc)
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Output rpc
-> ResponseTrailingMetadata rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc)
forall b a. a -> b -> StreamElem b a
FinalElem
sendTrailers ::
HasCallStack
=> Call rpc -> ResponseTrailingMetadata rpc -> IO ()
sendTrailers :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> ResponseTrailingMetadata rpc -> IO ()
sendTrailers Call rpc
call = Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ()
forall {k} (rpc :: k).
HasCallStack =>
Call rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ()
sendOutput Call rpc
call (StreamElem (ResponseTrailingMetadata rpc) (Output rpc) -> IO ())
-> (ResponseTrailingMetadata rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc))
-> ResponseTrailingMetadata rpc
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseTrailingMetadata rpc
-> StreamElem (ResponseTrailingMetadata rpc) (Output rpc)
forall b a. b -> StreamElem b a
NoMoreElems
recvNextInput :: forall rpc. HasCallStack => Call rpc -> IO (Input rpc)
recvNextInput :: forall {k} (rpc :: k). HasCallStack => Call rpc -> IO (Input rpc)
recvNextInput call :: Call rpc
call@Call{} = do
mInp <- Call rpc -> IO (NextElem (Input rpc))
forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (NextElem (Input rpc))
recvNextInputElem Call rpc
call
case mInp of
NextElem (Input rpc)
NoNextElem -> ProtocolException rpc -> IO (Input rpc)
forall a. ProtocolException rpc -> IO a
err (ProtocolException rpc -> IO (Input rpc))
-> ProtocolException rpc -> IO (Input rpc)
forall a b. (a -> b) -> a -> b
$ forall (rpc :: k). ProtocolException rpc
forall {k} (rpc :: k). ProtocolException rpc
TooFewInputs @rpc
NextElem Input rpc
inp -> Input rpc -> IO (Input rpc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Input rpc
inp
where
err :: ProtocolException rpc -> IO a
err :: forall a. ProtocolException rpc -> IO a
err = SomeProtocolException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (SomeProtocolException -> IO a)
-> (ProtocolException rpc -> SomeProtocolException)
-> ProtocolException rpc
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolException rpc -> SomeProtocolException
forall {k} (rpc :: k).
IsRPC rpc =>
ProtocolException rpc -> SomeProtocolException
ProtocolException
recvFinalInput :: forall rpc. HasCallStack => Call rpc -> IO (Input rpc)
recvFinalInput :: forall {k} (rpc :: k). HasCallStack => Call rpc -> IO (Input rpc)
recvFinalInput call :: Call rpc
call@Call{} = do
inp1 <- Call rpc -> IO (StreamElem NoMetadata (Input rpc))
forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (StreamElem NoMetadata (Input rpc))
recvInput Call rpc
call
case inp1 of
NoMoreElems NoMetadata
NoMetadata -> ProtocolException rpc -> IO (Input rpc)
forall a. ProtocolException rpc -> IO a
err (ProtocolException rpc -> IO (Input rpc))
-> ProtocolException rpc -> IO (Input rpc)
forall a b. (a -> b) -> a -> b
$ forall (rpc :: k). ProtocolException rpc
forall {k} (rpc :: k). ProtocolException rpc
TooFewInputs @rpc
FinalElem Input rpc
inp NoMetadata
NoMetadata -> Input rpc -> IO (Input rpc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Input rpc
inp
StreamElem Input rpc
inp -> do
inp2 <- Call rpc -> IO (StreamElem NoMetadata (Input rpc))
forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (StreamElem NoMetadata (Input rpc))
recvInput Call rpc
call
case inp2 of
NoMoreElems NoMetadata
NoMetadata -> Input rpc -> IO (Input rpc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Input rpc
inp
FinalElem Input rpc
inp' NoMetadata
NoMetadata -> ProtocolException rpc -> IO (Input rpc)
forall a. ProtocolException rpc -> IO a
err (ProtocolException rpc -> IO (Input rpc))
-> ProtocolException rpc -> IO (Input rpc)
forall a b. (a -> b) -> a -> b
$ forall (rpc :: k). Input rpc -> ProtocolException rpc
forall {k} (rpc :: k). Input rpc -> ProtocolException rpc
TooManyInputs @rpc Input rpc
inp'
StreamElem Input rpc
inp' -> ProtocolException rpc -> IO (Input rpc)
forall a. ProtocolException rpc -> IO a
err (ProtocolException rpc -> IO (Input rpc))
-> ProtocolException rpc -> IO (Input rpc)
forall a b. (a -> b) -> a -> b
$ forall (rpc :: k). Input rpc -> ProtocolException rpc
forall {k} (rpc :: k). Input rpc -> ProtocolException rpc
TooManyInputs @rpc Input rpc
inp'
where
err :: ProtocolException rpc -> IO a
err :: forall a. ProtocolException rpc -> IO a
err = SomeProtocolException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (SomeProtocolException -> IO a)
-> (ProtocolException rpc -> SomeProtocolException)
-> ProtocolException rpc
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolException rpc -> SomeProtocolException
forall {k} (rpc :: k).
IsRPC rpc =>
ProtocolException rpc -> SomeProtocolException
ProtocolException
recvEndOfInput :: forall rpc. HasCallStack => Call rpc -> IO ()
recvEndOfInput :: forall {k} (rpc :: k). HasCallStack => Call rpc -> IO ()
recvEndOfInput call :: Call rpc
call@Call{} = do
mInp <- Call rpc -> IO (StreamElem NoMetadata (Input rpc))
forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (StreamElem NoMetadata (Input rpc))
recvInput Call rpc
call
case mInp of
NoMoreElems NoMetadata
NoMetadata -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
FinalElem Input rpc
inp NoMetadata
NoMetadata -> ProtocolException rpc -> IO ()
forall a. ProtocolException rpc -> IO a
err (ProtocolException rpc -> IO ()) -> ProtocolException rpc -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (rpc :: k). Input rpc -> ProtocolException rpc
forall {k} (rpc :: k). Input rpc -> ProtocolException rpc
TooManyInputs @rpc Input rpc
inp
StreamElem Input rpc
inp -> ProtocolException rpc -> IO ()
forall a. ProtocolException rpc -> IO a
err (ProtocolException rpc -> IO ()) -> ProtocolException rpc -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (rpc :: k). Input rpc -> ProtocolException rpc
forall {k} (rpc :: k). Input rpc -> ProtocolException rpc
TooManyInputs @rpc Input rpc
inp
where
err :: ProtocolException rpc -> IO a
err :: forall a. ProtocolException rpc -> IO a
err = SomeProtocolException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (SomeProtocolException -> IO a)
-> (ProtocolException rpc -> SomeProtocolException)
-> ProtocolException rpc
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolException rpc -> SomeProtocolException
forall {k} (rpc :: k).
IsRPC rpc =>
ProtocolException rpc -> SomeProtocolException
ProtocolException
sendProperTrailers :: Call rpc -> ProperTrailers -> IO ()
sendProperTrailers :: forall {k} (rpc :: k). Call rpc -> ProperTrailers -> IO ()
sendProperTrailers Call{ServerContext
callContext :: forall {k} (rpc :: k). Call rpc -> ServerContext
callContext :: ServerContext
callContext, TMVar Kickoff
callResponseKickoff :: forall {k} (rpc :: k). Call rpc -> TMVar Kickoff
callResponseKickoff :: TMVar Kickoff
callResponseKickoff, Channel (ServerSession rpc)
callChannel :: forall {k} (rpc :: k). Call rpc -> Channel (ServerSession rpc)
callChannel :: Channel (ServerSession rpc)
callChannel}
ProperTrailers
trailers = do
updated <-
STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
TMVar Kickoff -> Kickoff -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar Kickoff
callResponseKickoff (Kickoff -> STM Bool) -> Kickoff -> STM Bool
forall a b. (a -> b) -> a -> b
$
CallStack -> TrailersOnly -> Kickoff
KickoffTrailersOnly
CallStack
HasCallStack => CallStack
callStack
( (ProperTrailers, HKD Undecorated (Maybe ContentType))
-> TrailersOnly
forall (f :: * -> *).
(ProperTrailers_ f, HKD f (Maybe ContentType)) -> TrailersOnly_ f
properTrailersToTrailersOnly (
ProperTrailers
trailers
, ServerParams -> Maybe ContentType
serverContentType ServerParams
serverParams
)
)
unless updated $
Session.send callChannel (NoMoreElems trailers)
Session.waitForOutbound callChannel
where
ServerContext{ServerParams
serverParams :: ServerContext -> ServerParams
serverParams :: ServerParams
serverParams} = ServerContext
callContext
recvBoth :: forall rpc.
HasCallStack
=> Call rpc
-> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
recvBoth :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
recvBoth Call{Channel (ServerSession rpc)
callChannel :: forall {k} (rpc :: k). Call rpc -> Channel (ServerSession rpc)
callChannel :: Channel (ServerSession rpc)
callChannel} =
Either Void (StreamElem NoMetadata (InboundMeta, Input rpc))
-> StreamElem NoMetadata (InboundMeta, Input rpc)
flatten (Either Void (StreamElem NoMetadata (InboundMeta, Input rpc))
-> StreamElem NoMetadata (InboundMeta, Input rpc))
-> IO
(Either Void (StreamElem NoMetadata (InboundMeta, Input rpc)))
-> IO (StreamElem NoMetadata (InboundMeta, Input rpc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Channel (ServerSession rpc)
-> IO
(Either
(NoMessages (Inbound (ServerSession rpc)))
(StreamElem
(Trailers (Inbound (ServerSession rpc)))
(Message (Inbound (ServerSession rpc)))))
forall sess.
HasCallStack =>
Channel sess
-> IO
(Either
(NoMessages (Inbound sess))
(StreamElem (Trailers (Inbound sess)) (Message (Inbound sess))))
Session.recvBoth Channel (ServerSession rpc)
callChannel
where
flatten ::
Either
Void
(StreamElem NoMetadata (InboundMeta, Input rpc))
-> StreamElem NoMetadata (InboundMeta, Input rpc)
flatten :: Either Void (StreamElem NoMetadata (InboundMeta, Input rpc))
-> StreamElem NoMetadata (InboundMeta, Input rpc)
flatten (Left Void
impossible) = Void -> StreamElem NoMetadata (InboundMeta, Input rpc)
forall a. Void -> a
absurd Void
impossible
flatten (Right StreamElem NoMetadata (InboundMeta, Input rpc)
streamElem) = StreamElem NoMetadata (InboundMeta, Input rpc)
streamElem
recvEither :: forall rpc.
HasCallStack
=> Call rpc
-> IO (NextElem (InboundMeta, Input rpc))
recvEither :: forall {k} (rpc :: k).
HasCallStack =>
Call rpc -> IO (NextElem (InboundMeta, Input rpc))
recvEither Call{Channel (ServerSession rpc)
callChannel :: forall {k} (rpc :: k). Call rpc -> Channel (ServerSession rpc)
callChannel :: Channel (ServerSession rpc)
callChannel} =
Either Void (Either NoMetadata (InboundMeta, Input rpc))
-> NextElem (InboundMeta, Input rpc)
flatten (Either Void (Either NoMetadata (InboundMeta, Input rpc))
-> NextElem (InboundMeta, Input rpc))
-> IO (Either Void (Either NoMetadata (InboundMeta, Input rpc)))
-> IO (NextElem (InboundMeta, Input rpc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Channel (ServerSession rpc)
-> IO
(Either
(NoMessages (Inbound (ServerSession rpc)))
(Either
(Trailers (Inbound (ServerSession rpc)))
(Message (Inbound (ServerSession rpc)))))
forall sess.
HasCallStack =>
Channel sess
-> IO
(Either
(NoMessages (Inbound sess))
(Either (Trailers (Inbound sess)) (Message (Inbound sess))))
Session.recvEither Channel (ServerSession rpc)
callChannel
where
flatten ::
Either
Void
(Either NoMetadata (InboundMeta, Input rpc))
-> NextElem (InboundMeta, Input rpc)
flatten :: Either Void (Either NoMetadata (InboundMeta, Input rpc))
-> NextElem (InboundMeta, Input rpc)
flatten (Left Void
impossible) = Void -> NextElem (InboundMeta, Input rpc)
forall a. Void -> a
absurd Void
impossible
flatten (Right (Left NoMetadata
NoMetadata)) = NextElem (InboundMeta, Input rpc)
forall a. NextElem a
NoNextElem
flatten (Right (Right (InboundMeta, Input rpc)
msg)) = (InboundMeta, Input rpc) -> NextElem (InboundMeta, Input rpc)
forall a. a -> NextElem a
NextElem (InboundMeta, Input rpc)
msg
data HandlerTerminated = HandlerTerminated
deriving stock (Int -> HandlerTerminated -> ShowS
[HandlerTerminated] -> ShowS
HandlerTerminated -> String
(Int -> HandlerTerminated -> ShowS)
-> (HandlerTerminated -> String)
-> ([HandlerTerminated] -> ShowS)
-> Show HandlerTerminated
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HandlerTerminated -> ShowS
showsPrec :: Int -> HandlerTerminated -> ShowS
$cshow :: HandlerTerminated -> String
show :: HandlerTerminated -> String
$cshowList :: [HandlerTerminated] -> ShowS
showList :: [HandlerTerminated] -> ShowS
Show)
deriving anyclass (Show HandlerTerminated
Typeable HandlerTerminated
(Typeable HandlerTerminated, Show HandlerTerminated) =>
(HandlerTerminated -> SomeException)
-> (SomeException -> Maybe HandlerTerminated)
-> (HandlerTerminated -> String)
-> (HandlerTerminated -> Bool)
-> Exception HandlerTerminated
SomeException -> Maybe HandlerTerminated
HandlerTerminated -> Bool
HandlerTerminated -> String
HandlerTerminated -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: HandlerTerminated -> SomeException
toException :: HandlerTerminated -> SomeException
$cfromException :: SomeException -> Maybe HandlerTerminated
fromException :: SomeException -> Maybe HandlerTerminated
$cdisplayException :: HandlerTerminated -> String
displayException :: HandlerTerminated -> String
$cbacktraceDesired :: HandlerTerminated -> Bool
backtraceDesired :: HandlerTerminated -> Bool
Exception)
data ResponseAlreadyInitiated = ResponseAlreadyInitiated {
ResponseAlreadyInitiated -> CallStack
responseInitiatedFirst :: CallStack
, ResponseAlreadyInitiated -> CallStack
responseInitiatedAgain :: CallStack
}
deriving stock (Int -> ResponseAlreadyInitiated -> ShowS
[ResponseAlreadyInitiated] -> ShowS
ResponseAlreadyInitiated -> String
(Int -> ResponseAlreadyInitiated -> ShowS)
-> (ResponseAlreadyInitiated -> String)
-> ([ResponseAlreadyInitiated] -> ShowS)
-> Show ResponseAlreadyInitiated
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseAlreadyInitiated -> ShowS
showsPrec :: Int -> ResponseAlreadyInitiated -> ShowS
$cshow :: ResponseAlreadyInitiated -> String
show :: ResponseAlreadyInitiated -> String
$cshowList :: [ResponseAlreadyInitiated] -> ShowS
showList :: [ResponseAlreadyInitiated] -> ShowS
Show)
deriving anyclass (Show ResponseAlreadyInitiated
Typeable ResponseAlreadyInitiated
(Typeable ResponseAlreadyInitiated,
Show ResponseAlreadyInitiated) =>
(ResponseAlreadyInitiated -> SomeException)
-> (SomeException -> Maybe ResponseAlreadyInitiated)
-> (ResponseAlreadyInitiated -> String)
-> (ResponseAlreadyInitiated -> Bool)
-> Exception ResponseAlreadyInitiated
SomeException -> Maybe ResponseAlreadyInitiated
ResponseAlreadyInitiated -> Bool
ResponseAlreadyInitiated -> String
ResponseAlreadyInitiated -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: ResponseAlreadyInitiated -> SomeException
toException :: ResponseAlreadyInitiated -> SomeException
$cfromException :: SomeException -> Maybe ResponseAlreadyInitiated
fromException :: SomeException -> Maybe ResponseAlreadyInitiated
$cdisplayException :: ResponseAlreadyInitiated -> String
displayException :: ResponseAlreadyInitiated -> String
$cbacktraceDesired :: ResponseAlreadyInitiated -> Bool
backtraceDesired :: ResponseAlreadyInitiated -> Bool
Exception)
data ResponseInitialMetadataNotSet = ResponseInitialMetadataNotSet
deriving stock (Int -> ResponseInitialMetadataNotSet -> ShowS
[ResponseInitialMetadataNotSet] -> ShowS
ResponseInitialMetadataNotSet -> String
(Int -> ResponseInitialMetadataNotSet -> ShowS)
-> (ResponseInitialMetadataNotSet -> String)
-> ([ResponseInitialMetadataNotSet] -> ShowS)
-> Show ResponseInitialMetadataNotSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseInitialMetadataNotSet -> ShowS
showsPrec :: Int -> ResponseInitialMetadataNotSet -> ShowS
$cshow :: ResponseInitialMetadataNotSet -> String
show :: ResponseInitialMetadataNotSet -> String
$cshowList :: [ResponseInitialMetadataNotSet] -> ShowS
showList :: [ResponseInitialMetadataNotSet] -> ShowS
Show)
deriving anyclass (Show ResponseInitialMetadataNotSet
Typeable ResponseInitialMetadataNotSet
(Typeable ResponseInitialMetadataNotSet,
Show ResponseInitialMetadataNotSet) =>
(ResponseInitialMetadataNotSet -> SomeException)
-> (SomeException -> Maybe ResponseInitialMetadataNotSet)
-> (ResponseInitialMetadataNotSet -> String)
-> (ResponseInitialMetadataNotSet -> Bool)
-> Exception ResponseInitialMetadataNotSet
SomeException -> Maybe ResponseInitialMetadataNotSet
ResponseInitialMetadataNotSet -> Bool
ResponseInitialMetadataNotSet -> String
ResponseInitialMetadataNotSet -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: ResponseInitialMetadataNotSet -> SomeException
toException :: ResponseInitialMetadataNotSet -> SomeException
$cfromException :: SomeException -> Maybe ResponseInitialMetadataNotSet
fromException :: SomeException -> Maybe ResponseInitialMetadataNotSet
$cdisplayException :: ResponseInitialMetadataNotSet -> String
displayException :: ResponseInitialMetadataNotSet -> String
$cbacktraceDesired :: ResponseInitialMetadataNotSet -> Bool
backtraceDesired :: ResponseInitialMetadataNotSet -> Bool
Exception)