module Network.GRPC.Util.HTTP2.Stream (
    -- * Streams
    OutputStream -- opaque
  , writeChunk
  , writeChunkFinal
  , flush
  , InputStream -- opaque
  , getChunk
  , getTrailers
    -- * Server API
  , serverOutputStream
  , serverInputStream
    -- ** Client API
  , clientInputStream
  , clientOutputStream
    -- * Exceptions
  , ClientDisconnected(..)
  , ServerDisconnected(..)
  , wrapStreamExceptionsWith
  ) where

import Control.Exception
import Data.Binary.Builder (Builder)
import Data.ByteString qualified as Strict (ByteString)
import GHC.Stack
import Network.HTTP.Types qualified as HTTP
import Network.HTTP2.Client qualified as Client
import Network.HTTP2.Server qualified as Server
import Network.HTTP2.Server (OutBodyIface(..))

import Network.GRPC.Util.HTTP2 (fromHeaderTable)

{-------------------------------------------------------------------------------
  Streams
-------------------------------------------------------------------------------}

data OutputStream = OutputStream {
      -- | Write a chunk to the stream
      OutputStream -> HasCallStack => Builder -> IO ()
_writeChunk :: HasCallStack => Builder -> IO ()

      -- | Write the final chunk to the stream
    , OutputStream -> HasCallStack => Builder -> IO ()
_writeChunkFinal :: HasCallStack => Builder -> IO ()

      -- | Flush the stream (send frames to the peer)
    , OutputStream -> HasCallStack => IO ()
_flush :: HasCallStack => IO ()
    }

data InputStream = InputStream {
      InputStream -> HasCallStack => IO (ByteString, Bool)
_getChunk    :: HasCallStack => IO (Strict.ByteString, Bool)
    , InputStream -> HasCallStack => IO [Header]
_getTrailers :: HasCallStack => IO [HTTP.Header]
    }

{-------------------------------------------------------------------------------
  Wrappers to get the proper CallStack
-------------------------------------------------------------------------------}

writeChunk :: HasCallStack => OutputStream -> Builder -> IO ()
writeChunk :: HasCallStack => OutputStream -> Builder -> IO ()
writeChunk = OutputStream -> HasCallStack => Builder -> IO ()
OutputStream -> Builder -> IO ()
_writeChunk

writeChunkFinal :: HasCallStack => OutputStream -> Builder -> IO ()
writeChunkFinal :: HasCallStack => OutputStream -> Builder -> IO ()
writeChunkFinal = OutputStream -> HasCallStack => Builder -> IO ()
OutputStream -> Builder -> IO ()
_writeChunkFinal

flush :: HasCallStack => OutputStream -> IO ()
flush :: HasCallStack => OutputStream -> IO ()
flush = OutputStream -> IO ()
OutputStream -> HasCallStack => IO ()
_flush

getChunk :: HasCallStack => InputStream -> IO (Strict.ByteString, Bool)
getChunk :: HasCallStack => InputStream -> IO (ByteString, Bool)
getChunk = InputStream -> IO (ByteString, Bool)
InputStream -> HasCallStack => IO (ByteString, Bool)
_getChunk

getTrailers :: HasCallStack => InputStream -> IO [HTTP.Header]
getTrailers :: HasCallStack => InputStream -> IO [Header]
getTrailers = InputStream -> IO [Header]
InputStream -> HasCallStack => IO [Header]
_getTrailers

{-------------------------------------------------------------------------------
  Server API
-------------------------------------------------------------------------------}

serverInputStream :: Server.Request -> IO InputStream
serverInputStream :: Request -> IO InputStream
serverInputStream Request
req = do
    InputStream -> IO InputStream
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream {
        _getChunk :: HasCallStack => IO (ByteString, Bool)
_getChunk =
           (SomeException -> CallStack -> ClientDisconnected)
-> IO (ByteString, Bool) -> IO (ByteString, Bool)
forall e a.
(HasCallStack, Exception e) =>
(SomeException -> CallStack -> e) -> IO a -> IO a
wrapStreamExceptionsWith SomeException -> CallStack -> ClientDisconnected
ClientDisconnected (IO (ByteString, Bool) -> IO (ByteString, Bool))
-> IO (ByteString, Bool) -> IO (ByteString, Bool)
forall a b. (a -> b) -> a -> b
$
             Request -> IO (ByteString, Bool)
Server.getRequestBodyChunk' Request
req
      , _getTrailers :: HasCallStack => IO [Header]
_getTrailers =
           (SomeException -> CallStack -> ClientDisconnected)
-> IO [Header] -> IO [Header]
forall e a.
(HasCallStack, Exception e) =>
(SomeException -> CallStack -> e) -> IO a -> IO a
wrapStreamExceptionsWith SomeException -> CallStack -> ClientDisconnected
ClientDisconnected (IO [Header] -> IO [Header]) -> IO [Header] -> IO [Header]
forall a b. (a -> b) -> a -> b
$
             [Header]
-> (TokenHeaderTable -> [Header])
-> Maybe TokenHeaderTable
-> [Header]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] TokenHeaderTable -> [Header]
fromHeaderTable (Maybe TokenHeaderTable -> [Header])
-> IO (Maybe TokenHeaderTable) -> IO [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> IO (Maybe TokenHeaderTable)
Server.getRequestTrailers Request
req
      }

-- | Create output stream
--
-- == Note on the use of Trailers-Only in non-error cases
--
-- If the stream is closed without writing anything, the situation is similar to
-- the gRPC @Trailers-Only@ case, except that we have already sent the initial
-- set of headers. In this case, http2 will (reasonably enough) create an empty
-- DATA frame, and then another HEADERS frame for the trailers. This is conform
-- the gRPC specification, which mandates:
--
-- > Most responses are expected to have both headers and trailers but
-- > Trailers-Only is permitted for calls that produce an immediate error.
--
-- If we compare this to the official Python example @RouteGuide@ server,
-- however, we see that the @Trailers-Only@ case is sometimes also used in
-- non-error cases. An example is @RouteGuide.listFeatures@: when there /are/ no
-- features in the specified rectangle, the server will send no messages back to
-- the client. The example Python server will use the gRPC Trailers-Only case
-- here (and so we must be able to deal with that in our client implementation).
--
-- We do provide this functionality, but only through a specific API (see
-- 'sendTrailersOnly'); when that API is used, we do not make use of this
-- 'OutputStream' abstraction (indeed, we do not stream at all). In streaming
-- cases (the default) we do not make use of @Trailers-Only@.
serverOutputStream :: OutBodyIface -> IO OutputStream
serverOutputStream :: OutBodyIface -> IO OutputStream
serverOutputStream OutBodyIface
iface = do
    -- Make sure that http2 does not wait for the first message before sending
    -- the response headers. This is important: the client might want the
    -- initial response metadata before the first message.
    --
    -- This does require some justification; if any of the reasons below is
    -- no longer true, we might need to reconsider:
    --
    -- o The extra cost of this flush is that we might need an additional TCP
    --   packet; no big deal.
    -- o We only create the 'OutputStream' once the user actually initiates the
    --   response, at which point the headers are fixed.
    -- o We do not use an 'OutputStream' at all when we are in the Trailers-Only
    --   case (see discussion above).

    let outputStream :: OutputStream
outputStream = OutputStream {
            _writeChunk :: HasCallStack => Builder -> IO ()
_writeChunk = \Builder
c ->
               (SomeException -> CallStack -> ClientDisconnected)
-> IO () -> IO ()
forall e a.
(HasCallStack, Exception e) =>
(SomeException -> CallStack -> e) -> IO a -> IO a
wrapStreamExceptionsWith SomeException -> CallStack -> ClientDisconnected
ClientDisconnected (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                 OutBodyIface -> Builder -> IO ()
outBodyPush OutBodyIface
iface Builder
c
          , _writeChunkFinal :: HasCallStack => Builder -> IO ()
_writeChunkFinal = \Builder
c ->
               (SomeException -> CallStack -> ClientDisconnected)
-> IO () -> IO ()
forall e a.
(HasCallStack, Exception e) =>
(SomeException -> CallStack -> e) -> IO a -> IO a
wrapStreamExceptionsWith SomeException -> CallStack -> ClientDisconnected
ClientDisconnected (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                 OutBodyIface -> Builder -> IO ()
outBodyPushFinal OutBodyIface
iface Builder
c
          , _flush :: HasCallStack => IO ()
_flush =
               (SomeException -> CallStack -> ClientDisconnected)
-> IO () -> IO ()
forall e a.
(HasCallStack, Exception e) =>
(SomeException -> CallStack -> e) -> IO a -> IO a
wrapStreamExceptionsWith SomeException -> CallStack -> ClientDisconnected
ClientDisconnected (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                 OutBodyIface -> IO ()
outBodyFlush OutBodyIface
iface
          }

    HasCallStack => OutputStream -> IO ()
OutputStream -> IO ()
flush OutputStream
outputStream
    OutputStream -> IO OutputStream
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream
outputStream

{-------------------------------------------------------------------------------
  Client API
-------------------------------------------------------------------------------}

clientInputStream :: Client.Response -> IO InputStream
clientInputStream :: Response -> IO InputStream
clientInputStream Response
resp = do
    InputStream -> IO InputStream
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream {
        _getChunk :: HasCallStack => IO (ByteString, Bool)
_getChunk =
           (SomeException -> CallStack -> ServerDisconnected)
-> IO (ByteString, Bool) -> IO (ByteString, Bool)
forall e a.
(HasCallStack, Exception e) =>
(SomeException -> CallStack -> e) -> IO a -> IO a
wrapStreamExceptionsWith SomeException -> CallStack -> ServerDisconnected
ServerDisconnected (IO (ByteString, Bool) -> IO (ByteString, Bool))
-> IO (ByteString, Bool) -> IO (ByteString, Bool)
forall a b. (a -> b) -> a -> b
$
             Response -> IO (ByteString, Bool)
Client.getResponseBodyChunk' Response
resp
      , _getTrailers :: HasCallStack => IO [Header]
_getTrailers =
           (SomeException -> CallStack -> ServerDisconnected)
-> IO [Header] -> IO [Header]
forall e a.
(HasCallStack, Exception e) =>
(SomeException -> CallStack -> e) -> IO a -> IO a
wrapStreamExceptionsWith SomeException -> CallStack -> ServerDisconnected
ServerDisconnected (IO [Header] -> IO [Header]) -> IO [Header] -> IO [Header]
forall a b. (a -> b) -> a -> b
$
             [Header]
-> (TokenHeaderTable -> [Header])
-> Maybe TokenHeaderTable
-> [Header]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] TokenHeaderTable -> [Header]
fromHeaderTable (Maybe TokenHeaderTable -> [Header])
-> IO (Maybe TokenHeaderTable) -> IO [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> IO (Maybe TokenHeaderTable)
Client.getResponseTrailers Response
resp
      }

-- | Construct a client 'OutputStream'
--
-- We do not wrap the members of the 'OutputStream' with
-- 'wrapStreamExceptionsWith', since we do this around the entire
-- 'sendMessageLoop'. See the comment for @outboundThread@ in
-- 'Network.GRPC.Util.Session.Client.setupRequestChannel'.
clientOutputStream :: OutBodyIface -> IO OutputStream
clientOutputStream :: OutBodyIface -> IO OutputStream
clientOutputStream OutBodyIface
iface =
    OutputStream -> IO OutputStream
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream {
        _writeChunk :: HasCallStack => Builder -> IO ()
_writeChunk = \Builder
c ->
          OutBodyIface -> Builder -> IO ()
outBodyPush OutBodyIface
iface Builder
c
      , _writeChunkFinal :: HasCallStack => Builder -> IO ()
_writeChunkFinal = \Builder
c ->
          OutBodyIface -> Builder -> IO ()
outBodyPushFinal OutBodyIface
iface Builder
c
      , _flush :: HasCallStack => IO ()
_flush =
          OutBodyIface -> IO ()
outBodyFlush OutBodyIface
iface
      }

{-------------------------------------------------------------------------------
  Exceptions
-------------------------------------------------------------------------------}

-- | Client disconnected unexpectedly
--
-- /If/ you choose to catch this exception, you are advised to match against
-- the type, rather than against the constructor, and then use the record
-- accessors to get access to the fields. Future versions of @grapesy@ may
-- record more information.
data ClientDisconnected = ClientDisconnected {
      ClientDisconnected -> SomeException
clientDisconnectedException :: SomeException
    , ClientDisconnected -> CallStack
clientDisconnectedCallStack :: CallStack
    }
  deriving stock (Int -> ClientDisconnected -> ShowS
[ClientDisconnected] -> ShowS
ClientDisconnected -> String
(Int -> ClientDisconnected -> ShowS)
-> (ClientDisconnected -> String)
-> ([ClientDisconnected] -> ShowS)
-> Show ClientDisconnected
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientDisconnected -> ShowS
showsPrec :: Int -> ClientDisconnected -> ShowS
$cshow :: ClientDisconnected -> String
show :: ClientDisconnected -> String
$cshowList :: [ClientDisconnected] -> ShowS
showList :: [ClientDisconnected] -> ShowS
Show)
  deriving anyclass (Show ClientDisconnected
Typeable ClientDisconnected
(Typeable ClientDisconnected, Show ClientDisconnected) =>
(ClientDisconnected -> SomeException)
-> (SomeException -> Maybe ClientDisconnected)
-> (ClientDisconnected -> String)
-> (ClientDisconnected -> Bool)
-> Exception ClientDisconnected
SomeException -> Maybe ClientDisconnected
ClientDisconnected -> Bool
ClientDisconnected -> String
ClientDisconnected -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: ClientDisconnected -> SomeException
toException :: ClientDisconnected -> SomeException
$cfromException :: SomeException -> Maybe ClientDisconnected
fromException :: SomeException -> Maybe ClientDisconnected
$cdisplayException :: ClientDisconnected -> String
displayException :: ClientDisconnected -> String
$cbacktraceDesired :: ClientDisconnected -> Bool
backtraceDesired :: ClientDisconnected -> Bool
Exception)

-- | Server disconnected unexpectedly
--
-- See comments for 'ClientDisconnected' on how to catch this exception.
data ServerDisconnected = ServerDisconnected {
      ServerDisconnected -> SomeException
serverDisconnectedException :: SomeException
    , ServerDisconnected -> CallStack
serverDisconnectedCallstack :: CallStack
    }
  deriving stock (Int -> ServerDisconnected -> ShowS
[ServerDisconnected] -> ShowS
ServerDisconnected -> String
(Int -> ServerDisconnected -> ShowS)
-> (ServerDisconnected -> String)
-> ([ServerDisconnected] -> ShowS)
-> Show ServerDisconnected
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerDisconnected -> ShowS
showsPrec :: Int -> ServerDisconnected -> ShowS
$cshow :: ServerDisconnected -> String
show :: ServerDisconnected -> String
$cshowList :: [ServerDisconnected] -> ShowS
showList :: [ServerDisconnected] -> ShowS
Show)
  deriving anyclass (Show ServerDisconnected
Typeable ServerDisconnected
(Typeable ServerDisconnected, Show ServerDisconnected) =>
(ServerDisconnected -> SomeException)
-> (SomeException -> Maybe ServerDisconnected)
-> (ServerDisconnected -> String)
-> (ServerDisconnected -> Bool)
-> Exception ServerDisconnected
SomeException -> Maybe ServerDisconnected
ServerDisconnected -> Bool
ServerDisconnected -> String
ServerDisconnected -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: ServerDisconnected -> SomeException
toException :: ServerDisconnected -> SomeException
$cfromException :: SomeException -> Maybe ServerDisconnected
fromException :: SomeException -> Maybe ServerDisconnected
$cdisplayException :: ServerDisconnected -> String
displayException :: ServerDisconnected -> String
$cbacktraceDesired :: ServerDisconnected -> Bool
backtraceDesired :: ServerDisconnected -> Bool
Exception)

wrapStreamExceptionsWith ::
     (HasCallStack, Exception e)
  => (SomeException -> CallStack -> e)
  -> IO a -> IO a
wrapStreamExceptionsWith :: forall e a.
(HasCallStack, Exception e) =>
(SomeException -> CallStack -> e) -> IO a -> IO a
wrapStreamExceptionsWith SomeException -> CallStack -> e
f IO a
action =
    IO a
action IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
err ->
      e -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (e -> IO a) -> e -> IO a
forall a b. (a -> b) -> a -> b
$ SomeException -> CallStack -> e
f SomeException
err CallStack
HasCallStack => CallStack
callStack