module Network.HTTP2.Client.Helpers (
upload
, waitStream
, fromStreamResult
, onPushPromise
, StreamResult
, StreamResponse
, 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 (threadDelay)
import Control.Concurrent.Async (race)
import Control.Monad (forever)
import Network.HTTP2.Client
data TimedOut = TimedOut
deriving Show
type PingReply = (UTCTime, UTCTime, Either TimedOut (HTTP2.FrameHeader, HTTP2.FramePayload))
ping :: Http2Client
-> Int
-> ByteString
-> IO PingReply
ping conn timeout msg = do
t0 <- getCurrentTime
waitPing <- _ping conn msg
pingReply <- race (threadDelay timeout >> return TimedOut) waitPing
t1 <- getCurrentTime
return $ (t0, t1, pingReply)
type StreamResult = (Either HTTP2.ErrorCode HPACK.HeaderList, [Either HTTP2.ErrorCode ByteString])
type StreamResponse = (HPACK.HeaderList, ByteString)
upload :: ByteString
-> Http2Client
-> OutgoingFlowControl
-> Http2Stream
-> OutgoingFlowControl
-> IO ()
upload "" conn _ stream _ = do
sendData conn stream HTTP2.setEndStream ""
upload dat conn connectionFlowControl stream streamFlowControl = do
let wanted = ByteString.length dat
gotStream <- _withdrawCredit streamFlowControl wanted
got <- _withdrawCredit connectionFlowControl gotStream
_receiveCredit streamFlowControl (gotStream got)
let uploadChunks flagMod =
sendData conn stream flagMod (ByteString.take got dat)
if got == wanted
then
uploadChunks HTTP2.setEndStream
else do
uploadChunks id
upload (ByteString.drop got dat) conn connectionFlowControl stream streamFlowControl
waitStream :: Http2Stream -> IncomingFlowControl -> IO StreamResult
waitStream stream streamFlowControl = do
(_,_,hdrs) <- _waitHeaders stream
dataFrames <- moredata []
return (hdrs, reverse dataFrames)
where
moredata xs = do
(fh, x) <- _waitData stream
if HTTP2.testEndStream (HTTP2.flags fh)
then
return (x:xs)
else do
_ <- _updateWindow $ streamFlowControl
moredata (x:xs)
fromStreamResult :: StreamResult -> Either HTTP2.ErrorCode StreamResponse
fromStreamResult (headersE, chunksE) = do
hdrs <- headersE
chunks <- sequence chunksE
return (hdrs, mconcat chunks)
onPushPromise :: Http2Stream -> PushPromiseHandler -> IO ()
onPushPromise stream handler = forever $ do
_waitPushPromise stream handler