{-# LANGUAGE OverloadedStrings #-}

-- | A toolbox with high-level functions to interact with an established HTTP2
-- conection.
--
-- These helpers make the assumption that you want to work in a multi-threaded
-- environment and that you want to send and receiving whole HTTP requests at
-- once (i.e., you do not care about streaming individual HTTP
-- requests/responses but want to make many requests).
module Network.HTTP2.Client.Helpers (
  -- * Sending and receiving HTTP body
    upload
  , waitStream
  , fromStreamResult 
  , StreamResult
  , StreamResponse
  -- * Diagnostics
  , ping
  , TimedOut
  , PingReply
  ) where

import           Data.Time.Clock (UTCTime, getCurrentTime)
import qualified Network.HTTP2.Frame as HTTP2
import qualified Network.HPACK as HPACK
import           Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import           Control.Concurrent.Lifted (threadDelay)
import           Control.Concurrent.Async.Lifted (race)

import Network.HTTP2.Client
import Network.HTTP2.Client.Exceptions

-- | Opaque type to express an action which timed out.
data TimedOut = TimedOut
  deriving WindowSize -> TimedOut -> ShowS
[TimedOut] -> ShowS
TimedOut -> [Char]
(WindowSize -> TimedOut -> ShowS)
-> (TimedOut -> [Char]) -> ([TimedOut] -> ShowS) -> Show TimedOut
forall a.
(WindowSize -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: WindowSize -> TimedOut -> ShowS
showsPrec :: WindowSize -> TimedOut -> ShowS
$cshow :: TimedOut -> [Char]
show :: TimedOut -> [Char]
$cshowList :: [TimedOut] -> ShowS
showList :: [TimedOut] -> ShowS
Show

-- | Result for a 'ping'.
type PingReply = (UTCTime, UTCTime, Either TimedOut (HTTP2.FrameHeader, HTTP2.FramePayload))

-- | Performs a 'ping' and waits for a reply up to a given timeout (in
-- microseconds).
ping :: Http2Client
     -- ^ client connection
     -> Int
     -- ^ timeout in microseconds
     -> ByteString
     -- ^ 8-bytes message to uniquely identify the reply
     -> ClientIO PingReply
ping :: Http2Client -> WindowSize -> ByteString -> ClientIO PingReply
ping Http2Client
conn WindowSize
timeout ByteString
msg = do
    UTCTime
t0 <- IO UTCTime -> ExceptT ClientError IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO UTCTime -> ExceptT ClientError IO UTCTime)
-> IO UTCTime -> ExceptT ClientError IO UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
    ClientIO (FrameHeader, FramePayload)
waitPing <- Http2Client
-> ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
_ping Http2Client
conn ByteString
msg
    Either TimedOut (FrameHeader, FramePayload)
pingReply <- ExceptT ClientError IO TimedOut
-> ClientIO (FrameHeader, FramePayload)
-> ExceptT
     ClientError IO (Either TimedOut (FrameHeader, FramePayload))
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m (Either a b)
race (WindowSize -> ExceptT ClientError IO ()
forall (m :: * -> *). MonadBase IO m => WindowSize -> m ()
threadDelay WindowSize
timeout ExceptT ClientError IO ()
-> ExceptT ClientError IO TimedOut
-> ExceptT ClientError IO TimedOut
forall a b.
ExceptT ClientError IO a
-> ExceptT ClientError IO b -> ExceptT ClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TimedOut -> ExceptT ClientError IO TimedOut
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TimedOut
TimedOut) ClientIO (FrameHeader, FramePayload)
waitPing
    UTCTime
t1 <- IO UTCTime -> ExceptT ClientError IO UTCTime
forall (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO UTCTime -> ExceptT ClientError IO UTCTime)
-> IO UTCTime -> ExceptT ClientError IO UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
    PingReply -> ClientIO PingReply
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PingReply -> ClientIO PingReply)
-> PingReply -> ClientIO PingReply
forall a b. (a -> b) -> a -> b
$ (UTCTime
t0, UTCTime
t1, Either TimedOut (FrameHeader, FramePayload)
pingReply)

-- | Result containing the unpacked headers and all frames received in on a
-- stream. See 'StreamResponse' and 'fromStreamResult' to get a higher-level
-- utility.
type StreamResult = (Either HTTP2.ErrorCode HPACK.HeaderList, [Either HTTP2.ErrorCode ByteString], Maybe HPACK.HeaderList)

-- | An HTTP2 response, once fully received, is made of headers and a payload.
type StreamResponse = (HPACK.HeaderList, ByteString, Maybe HPACK.HeaderList)

-- | Uploads a whole HTTP body at a time.
--
-- This function should be called at most once per stream.  This function
-- closes the stream with HTTP2.setEndStream chunk at the end.  If you want to
-- post data (e.g., streamed chunks) your way to avoid loading a whole
-- bytestring in RAM, please study the source code of this function first.
--
-- This function sends one chunk at a time respecting by preference:
-- - server's flow control desires
-- - server's chunking preference
--
-- Uploading an empty bytestring will send a single DATA frame with
-- setEndStream and no payload.
upload :: ByteString
       -- ^ HTTP body.
       -> (HTTP2.FrameFlags -> HTTP2.FrameFlags)
       -- ^ Flag modifier for the last DATA frame sent.
       -> Http2Client
       -- ^ The client.
       -> OutgoingFlowControl
       -- ^ The outgoing flow control for this client. (We might remove this
       -- argument in the future because we can get it from the previous
       -- argument.
       -> Http2Stream
       -- ^ The corresponding HTTP stream.
       -> OutgoingFlowControl
       -- ^ The flow control for this stream.
       -> ClientIO ()
upload :: ByteString
-> (FrameFlags -> FrameFlags)
-> Http2Client
-> OutgoingFlowControl
-> Http2Stream
-> OutgoingFlowControl
-> ExceptT ClientError IO ()
upload ByteString
"" FrameFlags -> FrameFlags
flagmod Http2Client
conn OutgoingFlowControl
_ Http2Stream
stream OutgoingFlowControl
_ = do
    Http2Client
-> Http2Stream
-> (FrameFlags -> FrameFlags)
-> ByteString
-> ExceptT ClientError IO ()
sendData Http2Client
conn Http2Stream
stream FrameFlags -> FrameFlags
flagmod ByteString
""
upload ByteString
dat FrameFlags -> FrameFlags
flagmod Http2Client
conn OutgoingFlowControl
connectionFlowControl Http2Stream
stream OutgoingFlowControl
streamFlowControl = do
    let wanted :: WindowSize
wanted = ByteString -> WindowSize
ByteString.length ByteString
dat

    WindowSize
gotStream <- OutgoingFlowControl -> WindowSize -> ClientIO WindowSize
_withdrawCredit OutgoingFlowControl
streamFlowControl WindowSize
wanted
    WindowSize
got       <- OutgoingFlowControl -> WindowSize -> ClientIO WindowSize
_withdrawCredit OutgoingFlowControl
connectionFlowControl WindowSize
gotStream
    -- Recredit the stream flow control with the excedent we cannot spend on
    -- the connection.
    IO () -> ExceptT ClientError IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT ClientError IO ())
-> IO () -> ExceptT ClientError IO ()
forall a b. (a -> b) -> a -> b
$ OutgoingFlowControl -> WindowSize -> IO ()
_receiveCredit OutgoingFlowControl
streamFlowControl (WindowSize
gotStream WindowSize -> WindowSize -> WindowSize
forall a. Num a => a -> a -> a
- WindowSize
got)

    let uploadChunks :: (FrameFlags -> FrameFlags) -> ExceptT ClientError IO ()
uploadChunks FrameFlags -> FrameFlags
flagMod =
            Http2Client
-> Http2Stream
-> (FrameFlags -> FrameFlags)
-> ByteString
-> ExceptT ClientError IO ()
sendData Http2Client
conn Http2Stream
stream FrameFlags -> FrameFlags
flagMod (WindowSize -> ByteString -> ByteString
ByteString.take WindowSize
got ByteString
dat)

    if WindowSize
got WindowSize -> WindowSize -> Bool
forall a. Eq a => a -> a -> Bool
== WindowSize
wanted
    then
        (FrameFlags -> FrameFlags) -> ExceptT ClientError IO ()
uploadChunks FrameFlags -> FrameFlags
flagmod
    else do
        (FrameFlags -> FrameFlags) -> ExceptT ClientError IO ()
uploadChunks FrameFlags -> FrameFlags
forall a. a -> a
id
        ByteString
-> (FrameFlags -> FrameFlags)
-> Http2Client
-> OutgoingFlowControl
-> Http2Stream
-> OutgoingFlowControl
-> ExceptT ClientError IO ()
upload (WindowSize -> ByteString -> ByteString
ByteString.drop WindowSize
got ByteString
dat) FrameFlags -> FrameFlags
flagmod Http2Client
conn OutgoingFlowControl
connectionFlowControl Http2Stream
stream OutgoingFlowControl
streamFlowControl

-- | Wait for a stream until completion.
--
-- This function is fine if you don't want to consume results in chunks.  See
-- 'fromStreamResult' to collect the complicated 'StreamResult' into a simpler
-- 'StreamResponse'.
waitStream :: Http2Client
           -- ^The connection.
           -> Http2Stream
           -- ^The stream to wait on. This stream must be part of the connection.
           -> IncomingFlowControl
           -- ^Incoming flow control for the __stream__.
           -> PushPromiseHandler
           -> ClientIO StreamResult
waitStream :: Http2Client
-> Http2Stream
-> IncomingFlowControl
-> PushPromiseHandler
-> ClientIO StreamResult
waitStream Http2Client
conn Http2Stream
stream IncomingFlowControl
streamFlowControl PushPromiseHandler
ppHandler = do
    StreamEvent
ev <- Http2Stream -> ClientIO StreamEvent
_waitEvent Http2Stream
stream
    case StreamEvent
ev of
        StreamHeadersEvent FrameHeader
fH HeaderList
hdrs
            | FrameFlags -> Bool
HTTP2.testEndStream (FrameHeader -> FrameFlags
HTTP2.flags FrameHeader
fH) -> do
                StreamResult -> ClientIO StreamResult
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderList -> Either ErrorCode HeaderList
forall a b. b -> Either a b
Right HeaderList
hdrs, [], Maybe HeaderList
forall a. Maybe a
Nothing)
            | Bool
otherwise -> do
                ([Either ErrorCode ByteString]
dfrms,Maybe HeaderList
trls) <- [Either ErrorCode ByteString]
-> ExceptT
     ClientError IO ([Either ErrorCode ByteString], Maybe HeaderList)
forall {a}.
[Either a ByteString]
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
waitDataFrames []
                StreamResult -> ClientIO StreamResult
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderList -> Either ErrorCode HeaderList
forall a b. b -> Either a b
Right HeaderList
hdrs, [Either ErrorCode ByteString] -> [Either ErrorCode ByteString]
forall a. [a] -> [a]
reverse [Either ErrorCode ByteString]
dfrms, Maybe HeaderList
trls)
        StreamPushPromiseEvent FrameHeader
_ WindowSize
ppSid HeaderList
ppHdrs -> do
            Http2Stream
-> WindowSize
-> HeaderList
-> PushPromiseHandler
-> ExceptT ClientError IO ()
_handlePushPromise Http2Stream
stream WindowSize
ppSid HeaderList
ppHdrs PushPromiseHandler
ppHandler
            Http2Client
-> Http2Stream
-> IncomingFlowControl
-> PushPromiseHandler
-> ClientIO StreamResult
waitStream Http2Client
conn Http2Stream
stream IncomingFlowControl
streamFlowControl PushPromiseHandler
ppHandler
        StreamEvent
_ ->
            [Char] -> ClientIO StreamResult
forall a. HasCallStack => [Char] -> a
error ([Char] -> ClientIO StreamResult)
-> [Char] -> ClientIO StreamResult
forall a b. (a -> b) -> a -> b
$ [Char]
"expecting StreamHeadersEvent but got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ StreamEvent -> [Char]
forall a. Show a => a -> [Char]
show StreamEvent
ev
  where
    connFlowControl :: IncomingFlowControl
connFlowControl = Http2Client -> IncomingFlowControl
_incomingFlowControl Http2Client
conn
    waitDataFrames :: [Either a ByteString]
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
waitDataFrames [Either a ByteString]
xs = do
        StreamEvent
ev <- Http2Stream -> ClientIO StreamEvent
_waitEvent Http2Stream
stream
        case StreamEvent
ev of
            StreamDataEvent FrameHeader
fh ByteString
x
                | FrameFlags -> Bool
HTTP2.testEndStream (FrameHeader -> FrameFlags
HTTP2.flags FrameHeader
fh) ->
                    ([Either a ByteString], Maybe HeaderList)
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString -> Either a ByteString
forall a b. b -> Either a b
Right ByteString
x)Either a ByteString
-> [Either a ByteString] -> [Either a ByteString]
forall a. a -> [a] -> [a]
:[Either a ByteString]
xs, Maybe HeaderList
forall a. Maybe a
Nothing)
                | Bool
otherwise                            -> do
                    let size :: WindowSize
size = FrameHeader -> WindowSize
HTTP2.payloadLength FrameHeader
fh
                    WindowSize
_ <- IO WindowSize -> ClientIO WindowSize
forall (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO WindowSize -> ClientIO WindowSize)
-> IO WindowSize -> ClientIO WindowSize
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl -> WindowSize -> IO WindowSize
_consumeCredit IncomingFlowControl
streamFlowControl WindowSize
size
                    IO () -> ExceptT ClientError IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT ClientError IO ())
-> IO () -> ExceptT ClientError IO ()
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl -> WindowSize -> IO ()
_addCredit IncomingFlowControl
streamFlowControl WindowSize
size
                    Bool
_ <- IncomingFlowControl -> ClientIO Bool
_updateWindow (IncomingFlowControl -> ClientIO Bool)
-> IncomingFlowControl -> ClientIO Bool
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl
streamFlowControl
                    -- We also send a WINDOW_UPDATE for the connection in order
                    -- to not rely on external updateWindow calls. This reduces
                    -- latency and makes the function less error-prone to use.
                    -- Note that the main loop (dispatchLoop) already credits
                    -- the connection for received data frames, but it does not
                    -- send the WINDOW_UPDATE frames.. That is why we only send
                    -- those frames here, and we do not credit the connection
                    --  as we do the stream in the preceding lines.
                    Bool
_ <- IncomingFlowControl -> ClientIO Bool
_updateWindow (IncomingFlowControl -> ClientIO Bool)
-> IncomingFlowControl -> ClientIO Bool
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl
connFlowControl
                    [Either a ByteString]
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
waitDataFrames ((ByteString -> Either a ByteString
forall a b. b -> Either a b
Right ByteString
x)Either a ByteString
-> [Either a ByteString] -> [Either a ByteString]
forall a. a -> [a] -> [a]
:[Either a ByteString]
xs)
            StreamPushPromiseEvent FrameHeader
_ WindowSize
ppSid HeaderList
ppHdrs -> do
                Http2Stream
-> WindowSize
-> HeaderList
-> PushPromiseHandler
-> ExceptT ClientError IO ()
_handlePushPromise Http2Stream
stream WindowSize
ppSid HeaderList
ppHdrs PushPromiseHandler
ppHandler
                [Either a ByteString]
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
waitDataFrames [Either a ByteString]
xs
            StreamHeadersEvent FrameHeader
_ HeaderList
hdrs ->
                ([Either a ByteString], Maybe HeaderList)
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either a ByteString]
xs, HeaderList -> Maybe HeaderList
forall a. a -> Maybe a
Just HeaderList
hdrs)
            StreamEvent
_ ->
                [Char]
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ExceptT
      ClientError IO ([Either a ByteString], Maybe HeaderList))
-> [Char]
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
forall a b. (a -> b) -> a -> b
$ [Char]
"expecting StreamDataEvent but got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ StreamEvent -> [Char]
forall a. Show a => a -> [Char]
show StreamEvent
ev

-- | Converts a StreamResult to a StramResponse, stopping at the first error
-- using the `Either HTTP2.ErrorCode` monad.
fromStreamResult :: StreamResult -> Either HTTP2.ErrorCode StreamResponse
fromStreamResult :: StreamResult -> Either ErrorCode StreamResponse
fromStreamResult (Either ErrorCode HeaderList
headersE, [Either ErrorCode ByteString]
chunksE, Maybe HeaderList
trls) = do
    HeaderList
hdrs <- Either ErrorCode HeaderList
headersE
    [ByteString]
chunks <- [Either ErrorCode ByteString] -> Either ErrorCode [ByteString]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Either ErrorCode ByteString]
chunksE
    StreamResponse -> Either ErrorCode StreamResponse
forall a. a -> Either ErrorCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderList
hdrs, [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
chunks, Maybe HeaderList
trls)