{-# 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 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 Int -> TimedOut -> ShowS
[TimedOut] -> ShowS
TimedOut -> String
(Int -> TimedOut -> ShowS)
-> (TimedOut -> String) -> ([TimedOut] -> ShowS) -> Show TimedOut
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimedOut] -> ShowS
$cshowList :: [TimedOut] -> ShowS
show :: TimedOut -> String
$cshow :: TimedOut -> String
showsPrec :: Int -> TimedOut -> ShowS
$cshowsPrec :: Int -> 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 -> Int -> ByteString -> ClientIO PingReply
ping Http2Client
conn Int
timeout ByteString
msg = do
    UTCTime
t0 <- IO UTCTime -> ExceptT ClientError IO UTCTime
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 (Int -> ExceptT ClientError IO ()
forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay Int
timeout ExceptT ClientError IO ()
-> ExceptT ClientError IO TimedOut
-> ExceptT ClientError IO TimedOut
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TimedOut -> ExceptT ClientError IO TimedOut
forall (m :: * -> *) a. Monad m => a -> m a
return TimedOut
TimedOut) ClientIO (FrameHeader, FramePayload)
waitPing
    UTCTime
t1 <- IO UTCTime -> ExceptT ClientError IO UTCTime
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 (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 :: Int
wanted = ByteString -> Int
ByteString.length ByteString
dat

    Int
gotStream <- OutgoingFlowControl -> Int -> ClientIO Int
_withdrawCredit OutgoingFlowControl
streamFlowControl Int
wanted
    Int
got       <- OutgoingFlowControl -> Int -> ClientIO Int
_withdrawCredit OutgoingFlowControl
connectionFlowControl Int
gotStream
    -- Recredit the stream flow control with the excedent we cannot spend on
    -- the connection.
    IO () -> ExceptT ClientError IO ()
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 -> Int -> IO ()
_receiveCredit OutgoingFlowControl
streamFlowControl (Int
gotStream Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 (Int -> ByteString -> ByteString
ByteString.take Int
got ByteString
dat)

    if Int
got Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 (Int -> ByteString -> ByteString
ByteString.drop Int
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
-- 'StramResponse'.
waitStream :: Http2Stream
           -> IncomingFlowControl
           -> PushPromiseHandler
           -> ClientIO StreamResult
waitStream :: Http2Stream
-> IncomingFlowControl
-> PushPromiseHandler
-> ClientIO StreamResult
waitStream 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 (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 (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
_ Int
ppSid HeaderList
ppHdrs -> do
            Http2Stream
-> Int
-> HeaderList
-> PushPromiseHandler
-> ExceptT ClientError IO ()
_handlePushPromise Http2Stream
stream Int
ppSid HeaderList
ppHdrs PushPromiseHandler
ppHandler
            Http2Stream
-> IncomingFlowControl
-> PushPromiseHandler
-> ClientIO StreamResult
waitStream Http2Stream
stream IncomingFlowControl
streamFlowControl PushPromiseHandler
ppHandler
        StreamEvent
_ ->
            String -> ClientIO StreamResult
forall a. HasCallStack => String -> a
error (String -> ClientIO StreamResult)
-> String -> ClientIO StreamResult
forall a b. (a -> b) -> a -> b
$ String
"expecting StreamHeadersEvent but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ StreamEvent -> String
forall a. Show a => a -> String
show StreamEvent
ev
  where
    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 (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
                    Int
_ <- IO Int -> ClientIO Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Int -> ClientIO Int) -> IO Int -> ClientIO Int
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl -> Int -> IO Int
_consumeCredit IncomingFlowControl
streamFlowControl (FrameHeader -> Int
HTTP2.payloadLength FrameHeader
fh)
                    IO () -> ExceptT ClientError IO ()
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 -> Int -> IO ()
_addCredit IncomingFlowControl
streamFlowControl (FrameHeader -> Int
HTTP2.payloadLength FrameHeader
fh)
                    Bool
_ <- IncomingFlowControl -> ClientIO Bool
_updateWindow (IncomingFlowControl -> ClientIO Bool)
-> IncomingFlowControl -> ClientIO Bool
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl
streamFlowControl
                    [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
_ Int
ppSid HeaderList
ppHdrs -> do
                Http2Stream
-> Int
-> HeaderList
-> PushPromiseHandler
-> ExceptT ClientError IO ()
_handlePushPromise Http2Stream
stream Int
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 (m :: * -> *) a. Monad m => a -> m a
return ([Either a ByteString]
xs, HeaderList -> Maybe HeaderList
forall a. a -> Maybe a
Just HeaderList
hdrs)
            StreamEvent
_ ->
                String
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
forall a. HasCallStack => String -> a
error (String
 -> ExceptT
      ClientError IO ([Either a ByteString], Maybe HeaderList))
-> String
-> ExceptT ClientError IO ([Either a ByteString], Maybe HeaderList)
forall a b. (a -> b) -> a -> b
$ String
"expecting StreamDataEvent but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ StreamEvent -> String
forall a. Show a => a -> String
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)
sequence [Either ErrorCode ByteString]
chunksE
    StreamResponse -> Either ErrorCode StreamResponse
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)