-- | Node with server role (i.e., its peer is a client)
module Network.GRPC.Util.Session.Server (
    ConnectionToClient(..)
  , setupResponseChannel
  ) where

import Network.HTTP2.Server qualified as Server

import Network.GRPC.Util.HTTP2.Stream
import Network.GRPC.Util.Session.API
import Network.GRPC.Util.Session.Channel
import Network.GRPC.Util.Thread

{-------------------------------------------------------------------------------
  Connection
-------------------------------------------------------------------------------}

-- | Connection to the client, as provided by @http2@
data ConnectionToClient = ConnectionToClient {
      ConnectionToClient -> Request
request :: Server.Request
    , ConnectionToClient -> Response -> IO ()
respond :: Server.Response -> IO ()
    }

{-------------------------------------------------------------------------------
  Initiate response
-------------------------------------------------------------------------------}

-- | Setup response channel
--
-- Notes:
--
-- * The actual response will not immediately be initiated; see below.
-- * We assume that the client is allowed to close their outbound stream to us.
-- * 'setupResponseChannel' will not throw any exceptions.
setupResponseChannel :: forall sess.
     IsSession sess
  => sess
  -> ConnectionToClient
  -> FlowStart (Inbound sess)
  -> IO (FlowStart (Outbound sess), ResponseInfo)
  -- ^ Construct headers for the initial response
  --
  -- This function is allowed to block. If it does, no response will not be
  -- initiated until it returns.
  --
  -- If this function throws an exception, the response is never initiated;
  -- this is treated the same was as when we fail to set up the outbound
  -- connection due to a network failure.
  -> IO (Channel sess)
setupResponseChannel :: forall sess.
IsSession sess =>
sess
-> ConnectionToClient
-> FlowStart (Inbound sess)
-> IO (FlowStart (Outbound sess), ResponseInfo)
-> IO (Channel sess)
setupResponseChannel sess
sess
                     ConnectionToClient
conn
                     FlowStart (Inbound sess)
inboundStart
                     IO (FlowStart (Outbound sess), ResponseInfo)
startOutbound
                   = do
    channel <- IO (Channel sess)
forall sess. HasCallStack => IO (Channel sess)
initChannel

    forkThread "grapesy:serverInbound" (channelInbound channel) $
      \forall x. IO x -> IO x
unmask FlowState (Inbound sess) -> IO ()
markReady DebugThreadId
_debugId -> IO () -> IO ()
forall x. IO x -> IO x
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        AllowHalfClosed sess
-> Channel sess -> IO (InboundResult sess) -> IO ()
forall sess.
IsSession sess =>
AllowHalfClosed sess
-> Channel sess -> IO (InboundResult sess) -> IO ()
linkOutboundToInbound AllowHalfClosed sess
forall sess. AllowHalfClosed sess
ContinueWhenInboundClosed Channel sess
channel (IO (InboundResult sess) -> IO ())
-> IO (InboundResult sess) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          case FlowStart (Inbound sess)
inboundStart of
            FlowStartRegular Headers (Inbound sess)
headers -> do
              regular <- Headers (Inbound sess) -> IO (RegularFlowState (Inbound sess))
forall {k} (flow :: k). Headers flow -> IO (RegularFlowState flow)
initFlowStateRegular Headers (Inbound sess)
headers
              stream  <- serverInputStream (request conn)
              markReady $ FlowStateRegular regular
              Right <$> recvMessageLoop sess regular stream
            FlowStartNoMessages NoMessages (Inbound sess)
trailers -> do
              -- The client sent a request with an empty body
              FlowState (Inbound sess) -> IO ()
markReady (FlowState (Inbound sess) -> IO ())
-> FlowState (Inbound sess) -> IO ()
forall a b. (a -> b) -> a -> b
$ NoMessages (Inbound sess) -> FlowState (Inbound sess)
forall {k} (flow :: k). NoMessages flow -> FlowState flow
FlowStateNoMessages NoMessages (Inbound sess)
trailers
              InboundResult sess -> IO (InboundResult sess)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InboundResult sess -> IO (InboundResult sess))
-> InboundResult sess -> IO (InboundResult sess)
forall a b. (a -> b) -> a -> b
$ NoMessages (Inbound sess) -> InboundResult sess
forall a b. a -> Either a b
Left NoMessages (Inbound sess)
trailers
              -- Thread terminates immediately

    forkThread "grapesy:serverOutbound" (channelOutbound channel) $
      \forall x. IO x -> IO x
unmask FlowState (Outbound sess) -> IO ()
markReady DebugThreadId
_debugId -> IO () -> IO ()
forall x. IO x -> IO x
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (outboundStart, responseInfo) <- IO (FlowStart (Outbound sess), ResponseInfo)
startOutbound
        case outboundStart of
          FlowStartRegular Headers (Outbound sess)
headers -> do
            regular <- Headers (Outbound sess) -> IO (RegularFlowState (Outbound sess))
forall {k} (flow :: k). Headers flow -> IO (RegularFlowState flow)
initFlowStateRegular Headers (Outbound sess)
headers
            markReady $ FlowStateRegular regular
            let resp :: Server.Response
                resp = sess
-> Channel sess
-> RegularFlowState (Outbound sess)
-> Response
-> Response
forall sess.
IsSession sess =>
sess
-> Channel sess
-> RegularFlowState (Outbound sess)
-> Response
-> Response
setResponseTrailers sess
sess Channel sess
channel RegularFlowState (Outbound sess)
regular
                     (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> (OutBodyIface -> IO ()) -> Response
Server.responseStreamingIface
                             (ResponseInfo -> Status
responseStatus  ResponseInfo
responseInfo)
                             (ResponseInfo -> ResponseHeaders
responseHeaders ResponseInfo
responseInfo)
                     ((OutBodyIface -> IO ()) -> Response)
-> (OutBodyIface -> IO ()) -> Response
forall a b. (a -> b) -> a -> b
$ \OutBodyIface
iface -> do
                          stream <- OutBodyIface -> IO OutputStream
serverOutputStream OutBodyIface
iface
                          sendMessageLoop sess regular stream
            respond conn resp
          FlowStartNoMessages NoMessages (Outbound sess)
trailers -> do
            FlowState (Outbound sess) -> IO ()
markReady (FlowState (Outbound sess) -> IO ())
-> FlowState (Outbound sess) -> IO ()
forall a b. (a -> b) -> a -> b
$ NoMessages (Outbound sess) -> FlowState (Outbound sess)
forall {k} (flow :: k). NoMessages flow -> FlowState flow
FlowStateNoMessages NoMessages (Outbound sess)
trailers
            let resp :: Server.Response
                resp :: Response
resp = Status -> ResponseHeaders -> Response
Server.responseNoBody
                         (ResponseInfo -> Status
responseStatus  ResponseInfo
responseInfo)
                         (ResponseInfo -> ResponseHeaders
responseHeaders ResponseInfo
responseInfo)
            ConnectionToClient -> Response -> IO ()
respond ConnectionToClient
conn (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ Response
resp

    return channel

{-------------------------------------------------------------------------------
  Auxiliary http2
-------------------------------------------------------------------------------}

setResponseTrailers ::
     IsSession sess
  => sess
  -> Channel sess
  -> RegularFlowState (Outbound sess)
  -> Server.Response -> Server.Response
setResponseTrailers :: forall sess.
IsSession sess =>
sess
-> Channel sess
-> RegularFlowState (Outbound sess)
-> Response
-> Response
setResponseTrailers sess
sess Channel sess
channel RegularFlowState (Outbound sess)
regular Response
resp =
    Response -> TrailersMaker -> Response
Server.setResponseTrailersMaker Response
resp (TrailersMaker -> Response) -> TrailersMaker -> Response
forall a b. (a -> b) -> a -> b
$
      sess
-> Channel sess
-> RegularFlowState (Outbound sess)
-> TrailersMaker
forall sess.
IsSession sess =>
sess
-> Channel sess
-> RegularFlowState (Outbound sess)
-> TrailersMaker
outboundTrailersMaker sess
sess Channel sess
channel RegularFlowState (Outbound sess)
regular