{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE OverloadedStrings  #-}

-- | This module defines a set of low-level primitives for starting an HTTP2
-- session and interacting with a server.
--
-- For higher-level primitives, please refer to Network.HTTP2.Client.Helpers .
module Network.HTTP2.Client (
    -- * Basics
      runHttp2Client
    , newHttp2Client
    , withHttp2Stream
    , headers
    , trailers
    , sendData
    -- * Starting clients
    , Http2Client(..)
    , PushPromiseHandler
    -- * Starting streams
    , StreamDefinition(..)
    , StreamStarter
    , TooMuchConcurrency(..)
    , StreamThread
    , Http2Stream(..)
    -- * Flow control
    , IncomingFlowControl(..)
    , OutgoingFlowControl(..)
    -- * Exceptions
    , linkAsyncs
    , RemoteSentGoAwayFrame(..)
    , GoAwayHandler
    , defaultGoAwayHandler
    -- * Misc.
    , FallBackFrameHandler
    , ignoreFallbackHandler
    , FlagSetter
    , Http2ClientAsyncs(..)
    , _gtfo
    -- * Convenience re-exports
    , StreamEvent(..)
    , module Network.HTTP2.Client.FrameConnection
    , module Network.HTTP2.Client.Exceptions
    , module Network.Socket
    , module Network.TLS
    ) where

import           Control.Concurrent.Async.Lifted (Async, async, race, withAsync, link)
import           Control.Exception.Lifted (bracket, throwIO, SomeException, catch)
import           Control.Concurrent.MVar.Lifted (newEmptyMVar, newMVar, putMVar, takeMVar, tryPutMVar)
import           Control.Concurrent.Lifted (threadDelay)
import           Control.Monad (forever, void, when, forM_)
import           Control.Monad.IO.Class (liftIO)
import           Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import           Data.IORef.Lifted (newIORef, atomicModifyIORef', readIORef)
import           Data.Maybe (fromMaybe)
import           Network.HPACK as HPACK
import           Network.HTTP2.Frame as HTTP2
import           Network.Socket (HostName, PortNumber)
import           Network.TLS (ClientParams)

import           Network.HTTP2.Client.Channels
import           Network.HTTP2.Client.Dispatch
import           Network.HTTP2.Client.Exceptions
import           Network.HTTP2.Client.FrameConnection

-- | Offers credit-based flow-control.
--
-- Any mutable changes are atomic and hence work as intended in a multithreaded
-- setup.
--
-- The design of the flow-control mechanism is subject to changes.  One
-- important thing to keep in mind with current implementation is that both the
-- connection and streams are credited with '_addCredit' as soon as DATA frames
-- arrive, hence no-need to account for the DATA frames (but you can account
-- for delay-bandwidth product for instance).
data IncomingFlowControl = IncomingFlowControl {
    IncomingFlowControl -> StreamId -> IO ()
_addCredit   :: WindowSize -> IO ()
  -- ^ Add credit (using a hidden mutable reference underneath). This function
  -- only does accounting, the IO only does mutable changes. See '_updateWindow'.
  , IncomingFlowControl -> StreamId -> IO StreamId
_consumeCredit :: WindowSize -> IO Int
  -- ^ Consumes some credit and returns the credit left.
  , IncomingFlowControl -> ClientIO Bool
_updateWindow :: ClientIO Bool
  -- ^ Sends a WINDOW_UPDATE frame crediting it with the whole amount credited
  -- since the last _updateWindow call. The boolean tells whether an update was
  -- actually sent or not. A reason for not sending an update is if there is no
  -- credit in the flow-control system.
  }

-- | Receives credit-based flow-control or block.
--
-- There is no way to observe the total amount of credit and receive/withdraw
-- are atomic hence this object is thread-safe. However we plan to propose an
-- STM-based API to allow withdrawing atomically from both the connection and a
-- per-stream 'OutgoingFlowControl' objects at a same time. Without such
-- atomicity one must ensure consumers do not exhaust the connection credit
-- before taking the per-stream credit (else they might prevent others sending
-- data without taking any).
--
-- Longer term we plan to hide outgoing-flow-control increment/decrement
-- altogether because exception between withdrawing credit and sending DATA
-- could mean lost credit (and hence hanging streams).
data OutgoingFlowControl = OutgoingFlowControl {
    OutgoingFlowControl -> StreamId -> IO ()
_receiveCredit  :: WindowSize -> IO ()
  -- ^ Add credit (using a hidden mutable reference underneath).
  , OutgoingFlowControl -> StreamId -> ClientIO StreamId
_withdrawCredit :: WindowSize -> ClientIO WindowSize
  -- ^ Wait until we can take credit from stash. The returned value correspond
  -- to the amount that could be withdrawn, which is min(current, wanted). A
  -- caller should withdraw credit to send DATA chunks and put back any unused
  -- credit with _receiveCredit.
  }

-- | Defines a client stream.
--
-- Please red the doc for this record fields and then see 'StreamStarter'.
data StreamDefinition a = StreamDefinition {
    forall a. StreamDefinition a -> ClientIO StreamThread
_initStream   :: ClientIO StreamThread
  -- ^ Function to initialize a new client stream. This function runs in a
  -- exclusive-access section of the code and may prevent other threads to
  -- initialize new streams. Hence, you should ensure this IO does not wait for
  -- long periods of time.
  , forall a.
StreamDefinition a
-> IncomingFlowControl -> OutgoingFlowControl -> ClientIO a
_handleStream :: IncomingFlowControl -> OutgoingFlowControl -> ClientIO a
  -- ^ Function to operate with the stream. IncomingFlowControl currently is
  -- credited on your behalf as soon as a DATA frame arrives (and before you
  -- handle it with '_waitData'). However we do not send WINDOW_UPDATE with
  -- '_updateWindow'. This design may change in the future to give more leeway
  -- to library users.
  }

-- | Type alias for callback-based functions starting new streams.
--
-- The callback a user must provide takes an 'Http2Stream' and returns a
-- 'StreamDefinition'. This construction may seem wrong because a 'StreamDefinition'
-- contains an initialization and a handler functions. The explanation for this
-- twistedness is as follows: in HTTP2 stream-ids must be monotonically
-- increasing, if we want to support multi-threaded clients we need to
-- serialize access to a critical region of the code when clients send
-- HEADERS+CONTINUATIONs frames.
--
-- Passing the 'Http2Stream' object as part of the callback avoids leaking the
-- implementation of the critical region, meanwhile, the 'StreamDefinition'
-- delimits this critical region.
type StreamStarter a =
     (Http2Stream -> StreamDefinition a) -> ClientIO (Either TooMuchConcurrency a)

-- | Whether or not the client library believes the server will reject the new
-- stream. The Int content corresponds to the number of streams that should end
-- before accepting more streams. A reason this number can be more than zero is
-- that servers can change (and hence reduce) the advertised number of allowed
-- 'maxConcurrentStreams' at any time.
newtype TooMuchConcurrency = TooMuchConcurrency { TooMuchConcurrency -> StreamId
_getStreamRoomNeeded :: Int }
    deriving StreamId -> TooMuchConcurrency -> ShowS
[TooMuchConcurrency] -> ShowS
TooMuchConcurrency -> [Char]
(StreamId -> TooMuchConcurrency -> ShowS)
-> (TooMuchConcurrency -> [Char])
-> ([TooMuchConcurrency] -> ShowS)
-> Show TooMuchConcurrency
forall a.
(StreamId -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: StreamId -> TooMuchConcurrency -> ShowS
showsPrec :: StreamId -> TooMuchConcurrency -> ShowS
$cshow :: TooMuchConcurrency -> [Char]
show :: TooMuchConcurrency -> [Char]
$cshowList :: [TooMuchConcurrency] -> ShowS
showList :: [TooMuchConcurrency] -> ShowS
Show

-- | Record holding functions one can call while in an HTTP2 client session.
data Http2Client = Http2Client {
    Http2Client
-> ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
_ping             :: ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
  -- ^ Send a PING, the payload size must be exactly eight bytes.
  -- Returns an IO to wait for a ping reply. No timeout is provided. Only the
  -- first call to this IO will return if a reply is received. Hence we
  -- recommend wrapping this IO in an Async (e.g., with @race (threadDelay
  -- timeout)@.)
  , Http2Client
-> SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_settings         :: SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
  -- ^ Sends a SETTINGS. Returns an IO to wait for a settings reply. No timeout
  -- is provided. Only the first call to this IO will return if a reply is
  -- received. Hence we recommend wrapping this IO in an Async (e.g., with
  -- @race (threadDelay timeout)@.)
  , Http2Client -> ErrorCode -> ByteString -> ClientIO ()
_goaway           :: ErrorCode -> ByteString -> ClientIO ()
  -- ^ Sends a GOAWAY.
  , Http2Client -> forall a. StreamStarter a
_startStream      :: forall a. StreamStarter a
  -- ^ Spawns new streams. See 'StreamStarter'.
  , Http2Client -> IncomingFlowControl
_incomingFlowControl :: IncomingFlowControl
  -- ^ Simple getter for the 'IncomingFlowControl' for the whole client
  -- connection.
  , Http2Client -> OutgoingFlowControl
_outgoingFlowControl :: OutgoingFlowControl
  -- ^ Simple getter for the 'OutgoingFlowControl' for the whole client
  -- connection.
  , Http2Client -> IO PayloadSplitter
_payloadSplitter :: IO PayloadSplitter
  -- ^ Returns a function to split a payload.
  , Http2Client -> Http2ClientAsyncs
_asyncs         :: !Http2ClientAsyncs
  -- ^ Asynchronous operations threads.
  , Http2Client -> ClientIO ()
_close           :: ClientIO ()
  -- ^ Immediately stop processing incoming frames and closes the network
  -- connection.
  }

data InitHttp2Client = InitHttp2Client {
    InitHttp2Client
-> ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initPing                :: ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
  , InitHttp2Client
-> SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initSettings            :: SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
  , InitHttp2Client -> ErrorCode -> ByteString -> ClientIO ()
_initGoaway              :: ErrorCode -> ByteString -> ClientIO ()
  , InitHttp2Client -> forall a. StreamStarter a
_initStartStream         :: forall a. StreamStarter a
  , InitHttp2Client -> IncomingFlowControl
_initIncomingFlowControl :: IncomingFlowControl
  , InitHttp2Client -> OutgoingFlowControl
_initOutgoingFlowControl :: OutgoingFlowControl
  , InitHttp2Client -> IO PayloadSplitter
_initPaylodSplitter      :: IO PayloadSplitter
  , InitHttp2Client -> ClientIO ()
_initClose               :: ClientIO ()
  -- ^ Immediately closes the connection.
  , InitHttp2Client -> ClientIO Bool
_initStop                :: ClientIO Bool
  -- ^ Stops receiving frames.
  }

-- | Set of Async threads running an Http2Client.
--
-- This asyncs are linked to the thread where the Http2Client is created.
-- If you modify this structure to add more Async, please also modify
-- 'linkAsyncs' accordingly.
data Http2ClientAsyncs = Http2ClientAsyncs {
    Http2ClientAsyncs
-> Async (Either ClientError (FrameHeader, FramePayload))
_waitSettingsAsync   :: Async (Either ClientError (FrameHeader, FramePayload))
  -- ^ Async waiting for the initial settings ACK.
  , Http2ClientAsyncs -> Async (Either ClientError ())
_incomingFramesAsync :: Async (Either ClientError ())
  -- ^ Async responsible for ingesting all frames, increasing the
  -- maximum-received streamID and starting the frame dispatch. See
  -- 'dispatchFrames'.
  }

-- | Links all client's asyncs to current thread using:
-- @ link someUnderlyingAsync @ .
linkAsyncs :: Http2Client -> ClientIO ()
linkAsyncs :: Http2Client -> ClientIO ()
linkAsyncs Http2Client
client =
    let Http2ClientAsyncs{Async (Either ClientError ())
Async (Either ClientError (FrameHeader, FramePayload))
_waitSettingsAsync :: Http2ClientAsyncs
-> Async (Either ClientError (FrameHeader, FramePayload))
_incomingFramesAsync :: Http2ClientAsyncs -> Async (Either ClientError ())
_waitSettingsAsync :: Async (Either ClientError (FrameHeader, FramePayload))
_incomingFramesAsync :: Async (Either ClientError ())
..} = Http2Client -> Http2ClientAsyncs
_asyncs Http2Client
client in do
            Async (Either ClientError (FrameHeader, FramePayload))
-> ClientIO ()
forall (m :: * -> *) a. MonadBase IO m => Async a -> m ()
link Async (Either ClientError (FrameHeader, FramePayload))
_waitSettingsAsync
            Async (Either ClientError ()) -> ClientIO ()
forall (m :: * -> *) a. MonadBase IO m => Async a -> m ()
link Async (Either ClientError ())
_incomingFramesAsync

-- | Synonym of '_goaway'.
--
-- https://github.com/http2/http2-spec/pull/366
_gtfo :: Http2Client -> ErrorCode -> ByteString -> ClientIO ()
_gtfo :: Http2Client -> ErrorCode -> ByteString -> ClientIO ()
_gtfo = Http2Client -> ErrorCode -> ByteString -> ClientIO ()
_goaway

-- | Opaque proof that a client stream was initialized.
--
-- This type is only useful to force calling '_headers' in '_initStream' and
-- contains no information.
data StreamThread = CST

-- | Record holding functions one can call while in an HTTP2 client stream.
data Http2Stream = Http2Stream {
    Http2Stream
-> HeaderList
-> (FrameFlags -> FrameFlags)
-> ClientIO StreamThread
_headers      :: HPACK.HeaderList
                  -> (FrameFlags -> FrameFlags)
                  -> ClientIO StreamThread
  -- ^ Starts the stream with HTTP headers. Flags modifier can use
  -- 'setEndStream' if no data is required passed the last block of headers.
  -- Usually, this is the only call needed to build an '_initStream'.
  , Http2Stream -> Priority -> ClientIO ()
_prio         :: Priority -> ClientIO ()
  -- ^ Changes the PRIORITY of this stream.
  , Http2Stream -> ErrorCode -> ClientIO ()
_rst          :: ErrorCode -> ClientIO ()
  -- ^ Resets this stream with a RST frame. You should not use this stream past this call.
  , Http2Stream -> ClientIO StreamEvent
_waitEvent    :: ClientIO StreamEvent
  -- ^ Waits for the next event on the stream.
  , Http2Stream
-> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
_sendDataChunk     :: (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
  -- ^ Sends a DATA frame chunk. You can use send empty frames with only
  -- headers modifiers to close streams. This function is oblivious to framing
  -- and hence does not respect the RFC if sending large blocks. Use 'sendData'
  -- to chunk and send naively according to server\'s preferences. This function
  -- can be useful if you intend to handle the framing yourself.
  , Http2Stream
-> StreamId -> HeaderList -> PushPromiseHandler -> ClientIO ()
_handlePushPromise :: StreamId -> HeaderList -> PushPromiseHandler -> ClientIO ()
  }

-- | Sends HTTP trailers.
--
-- Trailers should be the last thing sent over a stream.
trailers :: Http2Stream -> HPACK.HeaderList -> (FrameFlags -> FrameFlags) -> ClientIO ()
trailers :: Http2Stream
-> HeaderList -> (FrameFlags -> FrameFlags) -> ClientIO ()
trailers Http2Stream
stream HeaderList
hdrs FrameFlags -> FrameFlags
flagmod = ClientIO StreamThread -> ClientIO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ClientIO StreamThread -> ClientIO ())
-> ClientIO StreamThread -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ Http2Stream
-> HeaderList
-> (FrameFlags -> FrameFlags)
-> ClientIO StreamThread
_headers Http2Stream
stream HeaderList
hdrs FrameFlags -> FrameFlags
flagmod

-- | Handler upon receiving a PUSH_PROMISE from the server.
--
-- The functions for 'Http2Stream' are similar to those used in ''. But callers
-- shall not use '_headers' to initialize the PUSH_PROMISE stream. Rather,
-- callers should 'waitHeaders' or '_rst' to reject the PUSH_PROMISE.
--
-- The StreamId corresponds to the parent stream as PUSH_PROMISEs are tied to a
-- client-initiated stream. Longer term we may move passing this handler to the
-- '_startStream' instead of 'newHttp2Client' (as it is for now).
type PushPromiseHandler =
    StreamId -> Http2Stream -> HeaderList -> IncomingFlowControl -> OutgoingFlowControl -> ClientIO ()

-- | Starts a new stream (i.e., one HTTP request + server-pushes).
--
-- You will typically call the returned 'StreamStarter' immediately to define
-- what you want to do with the Http2Stream.
--
-- @ _ <- (withHttp2Stream myClient $ \stream -> StreamDefinition _ _) @
--
-- Please refer to 'StreamStarter' and 'StreamDefinition' for more.
withHttp2Stream :: Http2Client -> StreamStarter a
withHttp2Stream :: forall a. Http2Client -> StreamStarter a
withHttp2Stream Http2Client
client = Http2Client -> forall a. StreamStarter a
_startStream Http2Client
client

-- | Type synonym for functions that modify flags.
--
-- Typical FlagSetter for library users are HTTP2.setEndHeader when sending
-- headers HTTP2.setEndStream to signal that there the client is not willing to
-- send more data.
--
-- We might use Endo in the future.
type FlagSetter = FrameFlags -> FrameFlags

-- | Sends the HTTP2+HTTP headers of your chosing.
--
-- You must add HTTP2 pseudo-headers first, followed by your typical HTTP
-- headers. This function makes no verification of this
-- ordering/exhaustinevess.
--
-- HTTP2 pseudo-headers replace the HTTP verb + parsed url as follows:
-- ":method" such as "GET",
-- ":scheme" such as "https",
-- ":path" such as "/blog/post/1234?foo=bar",
-- ":authority" such as "haskell.org"
--
-- Note that we currently enforce the 'HTTP2.setEndHeader' but this design
-- choice may change in the future. Hence, we recommend you use
-- 'HTTP2.setEndHeader' as well.
headers :: Http2Stream -> HeaderList -> FlagSetter -> ClientIO StreamThread
headers :: Http2Stream
-> HeaderList
-> (FrameFlags -> FrameFlags)
-> ClientIO StreamThread
headers = Http2Stream
-> HeaderList
-> (FrameFlags -> FrameFlags)
-> ClientIO StreamThread
_headers

-- | Starts a new Http2Client around a frame connection.
--
-- This function is slightly safer than 'startHttp2Client' because it uses
-- 'Control.Concurrent.Async.withAsync' instead of
-- 'Control.Concurrent.Async.async'; plus this function calls 'linkAsyncs' to
-- make sure that a network error kills the controlling thread. However, this
-- with-pattern takes the control of the thread and can be annoying at times.
--
-- This function tries to finalize the client with a call to `_close`, a second
-- call to `_close` will trigger an IOException because the Handle representing
-- the TCP connection will be closed.
runHttp2Client
  :: Http2FrameConnection
  -- ^ A frame connection.
  -> Int
  -- ^ The buffersize for the Network.HPACK encoder.
  -> Int
  -- ^ The buffersize for the Network.HPACK decoder.
  -> SettingsList
  -- ^ Initial SETTINGS that are sent as first frame.
  -> GoAwayHandler
  -- ^ Actions to run when the remote sends a GoAwayFrame
  -> FallBackFrameHandler
  -- ^ Actions to run when a control frame is not yet handled in http2-client
  -- lib (e.g., PRIORITY frames).
  -> (Http2Client -> ClientIO a)
  -- ^ Actions to run on the client.
  -> ClientIO a
runHttp2Client :: forall a.
Http2FrameConnection
-> StreamId
-> StreamId
-> SettingsList
-> GoAwayHandler
-> FallBackFrameHandler
-> (Http2Client -> ClientIO a)
-> ClientIO a
runHttp2Client Http2FrameConnection
conn StreamId
encoderBufSize StreamId
decoderBufSize SettingsList
initSettings GoAwayHandler
goAwayHandler FallBackFrameHandler
fallbackHandler Http2Client -> ClientIO a
mainHandler = do
    (ClientIO ()
incomingLoop, InitHttp2Client
initClient) <- Http2FrameConnection
-> StreamId
-> StreamId
-> GoAwayHandler
-> FallBackFrameHandler
-> ClientIO (ClientIO (), InitHttp2Client)
initHttp2Client Http2FrameConnection
conn StreamId
encoderBufSize StreamId
decoderBufSize GoAwayHandler
goAwayHandler FallBackFrameHandler
fallbackHandler
    ClientIO ()
-> (Async (StM (ExceptT ClientError IO) ()) -> ClientIO a)
-> ClientIO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> (Async (StM m a) -> m b) -> m b
withAsync ClientIO ()
incomingLoop ((Async (StM (ExceptT ClientError IO) ()) -> ClientIO a)
 -> ClientIO a)
-> (Async (StM (ExceptT ClientError IO) ()) -> ClientIO a)
-> ClientIO a
forall a b. (a -> b) -> a -> b
$ \Async (StM (ExceptT ClientError IO) ())
aIncoming -> do
        ClientIO (FrameHeader, FramePayload)
settsIO <- InitHttp2Client
-> SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initSettings InitHttp2Client
initClient SettingsList
initSettings
        ClientIO (FrameHeader, FramePayload)
-> (Async
      (StM (ExceptT ClientError IO) (FrameHeader, FramePayload))
    -> ClientIO a)
-> ClientIO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> (Async (StM m a) -> m b) -> m b
withAsync ClientIO (FrameHeader, FramePayload)
settsIO ((Async (StM (ExceptT ClientError IO) (FrameHeader, FramePayload))
  -> ClientIO a)
 -> ClientIO a)
-> (Async
      (StM (ExceptT ClientError IO) (FrameHeader, FramePayload))
    -> ClientIO a)
-> ClientIO a
forall a b. (a -> b) -> a -> b
$ \Async (StM (ExceptT ClientError IO) (FrameHeader, FramePayload))
aSettings -> do
            let client :: Http2Client
client = Http2Client {
              _settings :: SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_settings            = InitHttp2Client
-> SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initSettings InitHttp2Client
initClient
            , _ping :: ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
_ping                = InitHttp2Client
-> ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initPing InitHttp2Client
initClient
            , _goaway :: ErrorCode -> ByteString -> ClientIO ()
_goaway              = InitHttp2Client -> ErrorCode -> ByteString -> ClientIO ()
_initGoaway InitHttp2Client
initClient
            , _close :: ClientIO ()
_close               =
                InitHttp2Client -> ClientIO Bool
_initStop InitHttp2Client
initClient ClientIO Bool -> ClientIO () -> ClientIO ()
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
>> InitHttp2Client -> ClientIO ()
_initClose InitHttp2Client
initClient
            , _startStream :: forall a. StreamStarter a
_startStream         = InitHttp2Client -> forall a. StreamStarter a
_initStartStream InitHttp2Client
initClient
            , _incomingFlowControl :: IncomingFlowControl
_incomingFlowControl = InitHttp2Client -> IncomingFlowControl
_initIncomingFlowControl InitHttp2Client
initClient
            , _outgoingFlowControl :: OutgoingFlowControl
_outgoingFlowControl = InitHttp2Client -> OutgoingFlowControl
_initOutgoingFlowControl InitHttp2Client
initClient
            , _payloadSplitter :: IO PayloadSplitter
_payloadSplitter     = InitHttp2Client -> IO PayloadSplitter
_initPaylodSplitter InitHttp2Client
initClient
            , _asyncs :: Http2ClientAsyncs
_asyncs              = Async (Either ClientError (FrameHeader, FramePayload))
-> Async (Either ClientError ()) -> Http2ClientAsyncs
Http2ClientAsyncs Async (Either ClientError (FrameHeader, FramePayload))
Async (StM (ExceptT ClientError IO) (FrameHeader, FramePayload))
aSettings Async (Either ClientError ())
Async (StM (ExceptT ClientError IO) ())
aIncoming
            }
            Http2Client -> ClientIO ()
linkAsyncs Http2Client
client
            a
ret <- Http2Client -> ClientIO a
mainHandler Http2Client
client
            Http2Client -> ClientIO ()
_close Http2Client
client
            a -> ClientIO a
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret

-- | Starts a new Http2Client around a frame connection.
--
-- You may want to 'linkAsyncs' for a proper and automated cleanup of the
-- underlying threads.
newHttp2Client
  :: Http2FrameConnection
  -- ^ A frame connection.
  -> Int
  -- ^ The buffersize for the Network.HPACK encoder.
  -> Int
  -- ^ The buffersize for the Network.HPACK decoder.
  -> SettingsList
  -- ^ Initial SETTINGS that are sent as first frame.
  -> GoAwayHandler
  -- ^ Actions to run when the remote sends a GoAwayFrame
  -> FallBackFrameHandler
  -- ^ Actions to run when a control frame is not yet handled in http2-client
  -- lib (e.g., PRIORITY frames).
  -> ClientIO Http2Client
newHttp2Client :: Http2FrameConnection
-> StreamId
-> StreamId
-> SettingsList
-> GoAwayHandler
-> FallBackFrameHandler
-> ClientIO Http2Client
newHttp2Client Http2FrameConnection
conn StreamId
encoderBufSize StreamId
decoderBufSize SettingsList
initSettings GoAwayHandler
goAwayHandler FallBackFrameHandler
fallbackHandler = do
    (ClientIO ()
incomingLoop, InitHttp2Client
initClient) <- Http2FrameConnection
-> StreamId
-> StreamId
-> GoAwayHandler
-> FallBackFrameHandler
-> ClientIO (ClientIO (), InitHttp2Client)
initHttp2Client Http2FrameConnection
conn StreamId
encoderBufSize StreamId
decoderBufSize GoAwayHandler
goAwayHandler FallBackFrameHandler
fallbackHandler
    Async (Either ClientError ())
aIncoming <- ClientIO ()
-> ExceptT ClientError IO (Async (StM (ExceptT ClientError IO) ()))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async ClientIO ()
incomingLoop
    ClientIO (FrameHeader, FramePayload)
settsIO <- InitHttp2Client
-> SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initSettings InitHttp2Client
initClient SettingsList
initSettings
    Async (Either ClientError (FrameHeader, FramePayload))
aSettings <- ClientIO (FrameHeader, FramePayload)
-> ExceptT
     ClientError
     IO
     (Async (StM (ExceptT ClientError IO) (FrameHeader, FramePayload)))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async ClientIO (FrameHeader, FramePayload)
settsIO
    Http2Client -> ClientIO Http2Client
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Http2Client -> ClientIO Http2Client)
-> Http2Client -> ClientIO Http2Client
forall a b. (a -> b) -> a -> b
$ Http2Client {
        _settings :: SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_settings            = InitHttp2Client
-> SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initSettings InitHttp2Client
initClient
      , _ping :: ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
_ping                = InitHttp2Client
-> ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initPing InitHttp2Client
initClient
      , _goaway :: ErrorCode -> ByteString -> ClientIO ()
_goaway              = InitHttp2Client -> ErrorCode -> ByteString -> ClientIO ()
_initGoaway InitHttp2Client
initClient
      , _close :: ClientIO ()
_close               =
          InitHttp2Client -> ClientIO Bool
_initStop InitHttp2Client
initClient ClientIO Bool -> ClientIO () -> ClientIO ()
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
>> InitHttp2Client -> ClientIO ()
_initClose InitHttp2Client
initClient
      , _startStream :: forall a. StreamStarter a
_startStream         = InitHttp2Client -> forall a. StreamStarter a
_initStartStream InitHttp2Client
initClient
      , _incomingFlowControl :: IncomingFlowControl
_incomingFlowControl = InitHttp2Client -> IncomingFlowControl
_initIncomingFlowControl InitHttp2Client
initClient
      , _outgoingFlowControl :: OutgoingFlowControl
_outgoingFlowControl = InitHttp2Client -> OutgoingFlowControl
_initOutgoingFlowControl InitHttp2Client
initClient
      , _payloadSplitter :: IO PayloadSplitter
_payloadSplitter     = InitHttp2Client -> IO PayloadSplitter
_initPaylodSplitter InitHttp2Client
initClient
      , _asyncs :: Http2ClientAsyncs
_asyncs              = Async (Either ClientError (FrameHeader, FramePayload))
-> Async (Either ClientError ()) -> Http2ClientAsyncs
Http2ClientAsyncs Async (Either ClientError (FrameHeader, FramePayload))
aSettings Async (Either ClientError ())
aIncoming
      }

initHttp2Client
  :: Http2FrameConnection
  -> Int
  -> Int
  -> GoAwayHandler
  -> FallBackFrameHandler
  -> ClientIO (ClientIO (), InitHttp2Client)
initHttp2Client :: Http2FrameConnection
-> StreamId
-> StreamId
-> GoAwayHandler
-> FallBackFrameHandler
-> ClientIO (ClientIO (), InitHttp2Client)
initHttp2Client Http2FrameConnection
conn StreamId
encoderBufSize StreamId
decoderBufSize GoAwayHandler
goAwayHandler FallBackFrameHandler
fallbackHandler = do
    let controlStream :: Http2FrameClientStream
controlStream = Http2FrameConnection -> StreamId -> Http2FrameClientStream
makeFrameClientStream Http2FrameConnection
conn StreamId
0
    let ackPing :: ByteString -> ClientIO ()
ackPing = Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
sendPingFrame Http2FrameClientStream
controlStream FrameFlags -> FrameFlags
HTTP2.setAck
    let ackSettings :: ClientIO ()
ackSettings = Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> SettingsList -> ClientIO ()
sendSettingsFrame Http2FrameClientStream
controlStream FrameFlags -> FrameFlags
HTTP2.setAck []

    {- Setup for initial thread receiving server frames. -}
    Dispatch
dispatch  <- ExceptT ClientError IO Dispatch
forall (m :: * -> *). MonadBase IO m => m Dispatch
newDispatchIO
    DispatchControl
dispatchControl <- StreamId
-> (ByteString -> ClientIO ())
-> ClientIO ()
-> GoAwayHandler
-> FallBackFrameHandler
-> ExceptT ClientError IO DispatchControl
forall (m :: * -> *).
MonadBase IO m =>
StreamId
-> (ByteString -> ClientIO ())
-> ClientIO ()
-> GoAwayHandler
-> FallBackFrameHandler
-> m DispatchControl
newDispatchControlIO StreamId
encoderBufSize
                                            ByteString -> ClientIO ()
ackPing
                                            ClientIO ()
ackSettings
                                            GoAwayHandler
goAwayHandler
                                            FallBackFrameHandler
fallbackHandler

    let baseIncomingWindowSize :: IO StreamId
baseIncomingWindowSize = Settings -> StreamId
initialWindowSize (Settings -> StreamId)
-> (ConnectionSettings -> Settings)
-> ConnectionSettings
-> StreamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionSettings -> Settings
_clientSettings (ConnectionSettings -> StreamId)
-> IO ConnectionSettings -> IO StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> IO ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
dispatchControl
        baseOutgoingWindowSize :: IO StreamId
baseOutgoingWindowSize = Settings -> StreamId
initialWindowSize (Settings -> StreamId)
-> (ConnectionSettings -> Settings)
-> ConnectionSettings
-> StreamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionSettings -> Settings
_serverSettings (ConnectionSettings -> StreamId)
-> IO ConnectionSettings -> IO StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> IO ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
dispatchControl
    IncomingFlowControl
_initIncomingFlowControl <- IO IncomingFlowControl
-> ExceptT ClientError IO IncomingFlowControl
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 IncomingFlowControl
 -> ExceptT ClientError IO IncomingFlowControl)
-> IO IncomingFlowControl
-> ExceptT ClientError IO IncomingFlowControl
forall a b. (a -> b) -> a -> b
$ DispatchControl
-> IO StreamId
-> (StreamId -> ClientIO ())
-> IO IncomingFlowControl
newIncomingFlowControl DispatchControl
dispatchControl IO StreamId
baseIncomingWindowSize (Http2FrameClientStream -> StreamId -> ClientIO ()
sendWindowUpdateFrame Http2FrameClientStream
controlStream)
    Chan (FrameHeader, FramePayload)
windowUpdatesChan <- ExceptT ClientError IO (Chan (FrameHeader, FramePayload))
forall (m :: * -> *) a. MonadBase IO m => m (Chan a)
newChan
    OutgoingFlowControl
_initOutgoingFlowControl <- IO OutgoingFlowControl
-> ExceptT ClientError IO OutgoingFlowControl
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 OutgoingFlowControl
 -> ExceptT ClientError IO OutgoingFlowControl)
-> IO OutgoingFlowControl
-> ExceptT ClientError IO OutgoingFlowControl
forall a b. (a -> b) -> a -> b
$ DispatchControl
-> Chan (FrameHeader, FramePayload)
-> IO StreamId
-> IO OutgoingFlowControl
newOutgoingFlowControl DispatchControl
dispatchControl Chan (FrameHeader, FramePayload)
windowUpdatesChan IO StreamId
baseOutgoingWindowSize

    DispatchHPACK
dispatchHPACK <- StreamId -> ExceptT ClientError IO DispatchHPACK
forall (m :: * -> *). MonadBase IO m => StreamId -> m DispatchHPACK
newDispatchHPACKIO StreamId
decoderBufSize
    (ClientIO ()
incomingLoop,ClientIO Bool
endIncomingLoop) <- Http2FrameConnection
-> Dispatch
-> DispatchControl
-> Chan (FrameHeader, FramePayload)
-> IncomingFlowControl
-> DispatchHPACK
-> ClientIO (ClientIO (), ClientIO Bool)
dispatchLoop Http2FrameConnection
conn Dispatch
dispatch DispatchControl
dispatchControl Chan (FrameHeader, FramePayload)
windowUpdatesChan IncomingFlowControl
_initIncomingFlowControl DispatchHPACK
dispatchHPACK

    {- Setup for client-initiated streams. -}
    IORef StreamId
conccurentStreams <- StreamId -> ExceptT ClientError IO (IORef StreamId)
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef StreamId
0
    -- prepare client streams
    MVar StreamId
clientStreamIdMutex <- StreamId -> ExceptT ClientError IO (MVar StreamId)
forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar StreamId
0
    let withClientStreamId :: (StreamId -> m c) -> m c
withClientStreamId StreamId -> m c
h = m StreamId -> (StreamId -> m ()) -> (StreamId -> m c) -> m c
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (MVar StreamId -> m StreamId
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
takeMVar MVar StreamId
clientStreamIdMutex)
            (MVar StreamId -> StreamId -> m ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar StreamId
clientStreamIdMutex (StreamId -> m ()) -> (StreamId -> StreamId) -> StreamId -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamId -> StreamId
forall a. Enum a => a -> a
succ)
            (\StreamId
k -> StreamId -> m c
h (StreamId
2 StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
* StreamId
k StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
1)) -- Note: client StreamIds MUST be odd

    let _initStartStream :: (Http2Stream -> StreamDefinition b)
-> ExceptT ClientError IO (Either TooMuchConcurrency b)
_initStartStream Http2Stream -> StreamDefinition b
getWork = do
            StreamId
maxConcurrency <- StreamId -> Maybe StreamId -> StreamId
forall a. a -> Maybe a -> a
fromMaybe StreamId
100 (Maybe StreamId -> StreamId)
-> (ConnectionSettings -> Maybe StreamId)
-> ConnectionSettings
-> StreamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Maybe StreamId
maxConcurrentStreams (Settings -> Maybe StreamId)
-> (ConnectionSettings -> Settings)
-> ConnectionSettings
-> Maybe StreamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionSettings -> Settings
_serverSettings (ConnectionSettings -> StreamId)
-> ExceptT ClientError IO ConnectionSettings -> ClientIO StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> ExceptT ClientError IO ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
dispatchControl
            StreamId
roomNeeded <- IORef StreamId
-> (StreamId -> (StreamId, StreamId)) -> ClientIO StreamId
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef StreamId
conccurentStreams
                (\StreamId
n -> if StreamId
n StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
< StreamId
maxConcurrency then (StreamId
n StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
1, StreamId
0) else (StreamId
n, StreamId
1 StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
n StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
- StreamId
maxConcurrency))
            if StreamId
roomNeeded StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
0
            then
                Either TooMuchConcurrency b
-> ExceptT ClientError IO (Either TooMuchConcurrency b)
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TooMuchConcurrency b
 -> ExceptT ClientError IO (Either TooMuchConcurrency b))
-> Either TooMuchConcurrency b
-> ExceptT ClientError IO (Either TooMuchConcurrency b)
forall a b. (a -> b) -> a -> b
$ TooMuchConcurrency -> Either TooMuchConcurrency b
forall a b. a -> Either a b
Left (TooMuchConcurrency -> Either TooMuchConcurrency b)
-> TooMuchConcurrency -> Either TooMuchConcurrency b
forall a b. (a -> b) -> a -> b
$ StreamId -> TooMuchConcurrency
TooMuchConcurrency StreamId
roomNeeded
            else b -> Either TooMuchConcurrency b
forall a b. b -> Either a b
Right (b -> Either TooMuchConcurrency b)
-> ExceptT ClientError IO b
-> ExceptT ClientError IO (Either TooMuchConcurrency b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                Chan (FrameHeader, FramePayload)
windowUpdatesChan <- ExceptT ClientError IO (Chan (FrameHeader, FramePayload))
forall (m :: * -> *) a. MonadBase IO m => m (Chan a)
newChan
                ExceptT ClientError IO b
cont <- (StreamId -> ExceptT ClientError IO (ExceptT ClientError IO b))
-> ExceptT ClientError IO (ExceptT ClientError IO b)
forall {m :: * -> *} {c}.
MonadBaseControl IO m =>
(StreamId -> m c) -> m c
withClientStreamId ((StreamId -> ExceptT ClientError IO (ExceptT ClientError IO b))
 -> ExceptT ClientError IO (ExceptT ClientError IO b))
-> (StreamId -> ExceptT ClientError IO (ExceptT ClientError IO b))
-> ExceptT ClientError IO (ExceptT ClientError IO b)
forall a b. (a -> b) -> a -> b
$ \StreamId
sid -> do
                    DispatchStream
dispatchStream <- StreamId -> ExceptT ClientError IO DispatchStream
forall (m :: * -> *).
MonadBase IO m =>
StreamId -> m DispatchStream
newDispatchStreamIO StreamId
sid
                    Http2FrameConnection
-> Dispatch
-> DispatchControl
-> DispatchStream
-> Chan (FrameHeader, FramePayload)
-> (Http2Stream -> StreamDefinition b)
-> StreamFSMState
-> ExceptT ClientError IO (ExceptT ClientError IO b)
forall a.
Http2FrameConnection
-> Dispatch
-> DispatchControl
-> DispatchStream
-> Chan (FrameHeader, FramePayload)
-> (Http2Stream -> StreamDefinition a)
-> StreamFSMState
-> ClientIO (ClientIO a)
initializeStream Http2FrameConnection
conn
                                     Dispatch
dispatch
                                     DispatchControl
dispatchControl
                                     DispatchStream
dispatchStream
                                     Chan (FrameHeader, FramePayload)
windowUpdatesChan
                                     Http2Stream -> StreamDefinition b
getWork
                                     StreamFSMState
Idle
                b
v <- ExceptT ClientError IO b
cont
                IORef StreamId -> (StreamId -> (StreamId, ())) -> ClientIO ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef StreamId
conccurentStreams (\StreamId
n -> (StreamId
n StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
- StreamId
1, ()))
                b -> ExceptT ClientError IO b
forall a. a -> ExceptT ClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
v

    let _initPing :: ByteString
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
_initPing ByteString
dat = do
            PingHandler
handler <- IO PingHandler -> ExceptT ClientError IO PingHandler
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 PingHandler -> ExceptT ClientError IO PingHandler)
-> IO PingHandler -> ExceptT ClientError IO PingHandler
forall a b. (a -> b) -> a -> b
$ DispatchControl -> ByteString -> IO PingHandler
registerPingHandler DispatchControl
dispatchControl ByteString
dat
            Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
sendPingFrame Http2FrameClientStream
controlStream FrameFlags -> FrameFlags
forall a. a -> a
id ByteString
dat
            t m (FrameHeader, FramePayload)
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (t m (FrameHeader, FramePayload)
 -> ExceptT ClientError IO (t m (FrameHeader, FramePayload)))
-> t m (FrameHeader, FramePayload)
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
forall a b. (a -> b) -> a -> b
$ m (FrameHeader, FramePayload) -> t m (FrameHeader, FramePayload)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (FrameHeader, FramePayload) -> t m (FrameHeader, FramePayload))
-> m (FrameHeader, FramePayload) -> t m (FrameHeader, FramePayload)
forall a b. (a -> b) -> a -> b
$ PingHandler -> m (FrameHeader, FramePayload)
forall (m :: * -> *).
MonadBase IO m =>
PingHandler -> m (FrameHeader, FramePayload)
waitPingReply PingHandler
handler

    let _initSettings :: SettingsList
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
_initSettings SettingsList
settslist = do
            SetSettingsHandler
handler <- IO SetSettingsHandler -> ExceptT ClientError IO SetSettingsHandler
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 SetSettingsHandler
 -> ExceptT ClientError IO SetSettingsHandler)
-> IO SetSettingsHandler
-> ExceptT ClientError IO SetSettingsHandler
forall a b. (a -> b) -> a -> b
$ DispatchControl -> IO SetSettingsHandler
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m SetSettingsHandler
registerSetSettingsHandler DispatchControl
dispatchControl
            Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> SettingsList -> ClientIO ()
sendSettingsFrame Http2FrameClientStream
controlStream FrameFlags -> FrameFlags
forall a. a -> a
id SettingsList
settslist
            t m (FrameHeader, FramePayload)
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (t m (FrameHeader, FramePayload)
 -> ExceptT ClientError IO (t m (FrameHeader, FramePayload)))
-> t m (FrameHeader, FramePayload)
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
forall a b. (a -> b) -> a -> b
$ do
                (FrameHeader, FramePayload)
ret <- m (FrameHeader, FramePayload) -> t m (FrameHeader, FramePayload)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (FrameHeader, FramePayload) -> t m (FrameHeader, FramePayload))
-> m (FrameHeader, FramePayload) -> t m (FrameHeader, FramePayload)
forall a b. (a -> b) -> a -> b
$ SetSettingsHandler -> m (FrameHeader, FramePayload)
forall (m :: * -> *).
MonadBase IO m =>
SetSettingsHandler -> m (FrameHeader, FramePayload)
waitSetSettingsReply SetSettingsHandler
handler
                DispatchControl
-> (ConnectionSettings -> (ConnectionSettings, ())) -> t m ()
forall (m :: * -> *) a.
MonadBase IO m =>
DispatchControl
-> (ConnectionSettings -> (ConnectionSettings, a)) -> m a
modifySettings DispatchControl
dispatchControl
                    (\(ConnectionSettings Settings
cli Settings
srv) ->
                        (Settings -> Settings -> ConnectionSettings
ConnectionSettings (Settings -> SettingsList -> Settings
HTTP2.updateSettings Settings
cli SettingsList
settslist) Settings
srv, ()))
                (FrameHeader, FramePayload) -> t m (FrameHeader, FramePayload)
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FrameHeader, FramePayload)
ret
    let _initGoaway :: ErrorCode -> ByteString -> ClientIO ()
_initGoaway ErrorCode
err ByteString
errStr = do
            StreamId
sId <- IO StreamId -> ClientIO StreamId
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 StreamId -> ClientIO StreamId)
-> IO StreamId -> ClientIO StreamId
forall a b. (a -> b) -> a -> b
$ Dispatch -> IO StreamId
forall (m :: * -> *). MonadBase IO m => Dispatch -> m StreamId
readMaxReceivedStreamIdIO Dispatch
dispatch
            Http2FrameClientStream
-> StreamId -> ErrorCode -> ByteString -> ClientIO ()
sendGTFOFrame Http2FrameClientStream
controlStream StreamId
sId ErrorCode
err ByteString
errStr

    let _initPaylodSplitter :: IO PayloadSplitter
_initPaylodSplitter = ConnectionSettings -> PayloadSplitter
settingsPayloadSplitter (ConnectionSettings -> PayloadSplitter)
-> IO ConnectionSettings -> IO PayloadSplitter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> IO ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
dispatchControl

    let _initStop :: ClientIO Bool
_initStop = ClientIO Bool
endIncomingLoop

    let _initClose :: ClientIO ()
_initClose = Http2FrameConnection -> ClientIO ()
closeConnection Http2FrameConnection
conn

    (ClientIO (), InitHttp2Client)
-> ClientIO (ClientIO (), InitHttp2Client)
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientIO ()
incomingLoop, InitHttp2Client{IO PayloadSplitter
ClientIO Bool
ClientIO ()
OutgoingFlowControl
IncomingFlowControl
SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
ErrorCode -> ByteString -> ClientIO ()
(Http2Stream -> StreamDefinition a)
-> ExceptT ClientError IO (Either TooMuchConcurrency a)
forall a. StreamStarter a
forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadTrans t, MonadBase IO m) =>
ByteString
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadTrans t, MonadBase IO m, MonadBase IO (t m)) =>
SettingsList
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
_initPing :: ByteString -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initSettings :: SettingsList -> ClientIO (ClientIO (FrameHeader, FramePayload))
_initGoaway :: ErrorCode -> ByteString -> ClientIO ()
_initStartStream :: forall a. StreamStarter a
_initIncomingFlowControl :: IncomingFlowControl
_initOutgoingFlowControl :: OutgoingFlowControl
_initPaylodSplitter :: IO PayloadSplitter
_initClose :: ClientIO ()
_initStop :: ClientIO Bool
_initIncomingFlowControl :: IncomingFlowControl
_initOutgoingFlowControl :: OutgoingFlowControl
_initStartStream :: forall a. StreamStarter a
_initPing :: forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadTrans t, MonadBase IO m) =>
ByteString
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
_initSettings :: forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
(MonadTrans t, MonadBase IO m, MonadBase IO (t m)) =>
SettingsList
-> ExceptT ClientError IO (t m (FrameHeader, FramePayload))
_initGoaway :: ErrorCode -> ByteString -> ClientIO ()
_initPaylodSplitter :: IO PayloadSplitter
_initStop :: ClientIO Bool
_initClose :: ClientIO ()
..})

initializeStream
  :: Http2FrameConnection
  -> Dispatch
  -> DispatchControl
  -> DispatchStream
  -> Chan (FrameHeader, FramePayload)
  -> (Http2Stream -> StreamDefinition a)
  -> StreamFSMState
  -> ClientIO (ClientIO a)
initializeStream :: forall a.
Http2FrameConnection
-> Dispatch
-> DispatchControl
-> DispatchStream
-> Chan (FrameHeader, FramePayload)
-> (Http2Stream -> StreamDefinition a)
-> StreamFSMState
-> ClientIO (ClientIO a)
initializeStream Http2FrameConnection
conn Dispatch
dispatch DispatchControl
control DispatchStream
stream Chan (FrameHeader, FramePayload)
windowUpdatesChan Http2Stream -> StreamDefinition a
getWork StreamFSMState
initialState = do
    let sid :: StreamId
sid = DispatchStream -> StreamId
_dispatchStreamId DispatchStream
stream
    let frameStream :: Http2FrameClientStream
frameStream = Http2FrameConnection -> StreamId -> Http2FrameClientStream
makeFrameClientStream Http2FrameConnection
conn StreamId
sid

    let events :: Chan StreamEvent
events        = DispatchStream -> Chan StreamEvent
_dispatchStreamReadEvents DispatchStream
stream

    -- Prepare handlers.
    let _headers :: HeaderList -> (FrameFlags -> FrameFlags) -> ClientIO StreamThread
_headers HeaderList
headersList FrameFlags -> FrameFlags
flags = do
            PayloadSplitter
splitter <- ConnectionSettings -> PayloadSplitter
settingsPayloadSplitter (ConnectionSettings -> PayloadSplitter)
-> ExceptT ClientError IO ConnectionSettings
-> ExceptT ClientError IO PayloadSplitter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> ExceptT ClientError IO ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
control
            StreamThread
cst <- Http2FrameClientStream
-> HpackEncoderContext
-> HeaderList
-> PayloadSplitter
-> (FrameFlags -> FrameFlags)
-> ClientIO StreamThread
sendHeaders Http2FrameClientStream
frameStream (DispatchControl -> HpackEncoderContext
_dispatchControlHpackEncoder DispatchControl
control) HeaderList
headersList PayloadSplitter
splitter FrameFlags -> FrameFlags
flags
            Bool -> ClientIO () -> ClientIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameFlags -> Bool
testEndStream (FrameFlags -> Bool) -> FrameFlags -> Bool
forall a b. (a -> b) -> a -> b
$ FrameFlags -> FrameFlags
flags FrameFlags
0) (ClientIO () -> ClientIO ()) -> ClientIO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ do
                Dispatch -> StreamId -> ClientIO ()
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m ()
closeLocalStream Dispatch
dispatch StreamId
sid
            StreamThread -> ClientIO StreamThread
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamThread
cst
    let _waitEvent :: ClientIO StreamEvent
_waitEvent    = Chan StreamEvent -> ClientIO StreamEvent
forall (m :: * -> *) a. MonadBase IO m => Chan a -> m a
readChan Chan StreamEvent
events
    let _sendDataChunk :: (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
_sendDataChunk FrameFlags -> FrameFlags
flags ByteString
dat = do
            Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
sendDataFrame Http2FrameClientStream
frameStream FrameFlags -> FrameFlags
flags ByteString
dat
            Bool -> ClientIO () -> ClientIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameFlags -> Bool
testEndStream (FrameFlags -> Bool) -> FrameFlags -> Bool
forall a b. (a -> b) -> a -> b
$ FrameFlags -> FrameFlags
flags FrameFlags
0) (ClientIO () -> ClientIO ()) -> ClientIO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ do
                Dispatch -> StreamId -> ClientIO ()
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m ()
closeLocalStream Dispatch
dispatch StreamId
sid
    let _rst :: ErrorCode -> ClientIO ()
_rst = \ErrorCode
err -> do
            Http2FrameClientStream -> ErrorCode -> ClientIO ()
sendResetFrame Http2FrameClientStream
frameStream ErrorCode
err
            Dispatch -> StreamId -> ClientIO ()
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m ()
closeReleaseStream Dispatch
dispatch StreamId
sid
    let _prio :: Priority -> ClientIO ()
_prio           = Http2FrameClientStream -> Priority -> ClientIO ()
sendPriorityFrame Http2FrameClientStream
frameStream
    let _handlePushPromise :: StreamId
-> p
-> (StreamId
    -> Http2Stream
    -> p
    -> IncomingFlowControl
    -> OutgoingFlowControl
    -> ClientIO b)
-> ClientIO b
_handlePushPromise StreamId
ppSid p
ppHeaders StreamId
-> Http2Stream
-> p
-> IncomingFlowControl
-> OutgoingFlowControl
-> ClientIO b
ppHandler = do
            let mkStreamActions :: Http2Stream -> StreamDefinition b
mkStreamActions Http2Stream
s = ClientIO StreamThread
-> (IncomingFlowControl -> OutgoingFlowControl -> ClientIO b)
-> StreamDefinition b
forall a.
ClientIO StreamThread
-> (IncomingFlowControl -> OutgoingFlowControl -> ClientIO a)
-> StreamDefinition a
StreamDefinition (StreamThread -> ClientIO StreamThread
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamThread
CST) (StreamId
-> Http2Stream
-> p
-> IncomingFlowControl
-> OutgoingFlowControl
-> ClientIO b
ppHandler StreamId
sid Http2Stream
s p
ppHeaders)
            DispatchStream
newStream <- StreamId -> ExceptT ClientError IO DispatchStream
forall (m :: * -> *).
MonadBase IO m =>
StreamId -> m DispatchStream
newDispatchStreamIO StreamId
ppSid
            Chan (FrameHeader, FramePayload)
ppWindowsUpdatesChan <- ExceptT ClientError IO (Chan (FrameHeader, FramePayload))
forall (m :: * -> *) a. MonadBase IO m => m (Chan a)
newChan
            ClientIO b
ppCont <- Http2FrameConnection
-> Dispatch
-> DispatchControl
-> DispatchStream
-> Chan (FrameHeader, FramePayload)
-> (Http2Stream -> StreamDefinition b)
-> StreamFSMState
-> ClientIO (ClientIO b)
forall a.
Http2FrameConnection
-> Dispatch
-> DispatchControl
-> DispatchStream
-> Chan (FrameHeader, FramePayload)
-> (Http2Stream -> StreamDefinition a)
-> StreamFSMState
-> ClientIO (ClientIO a)
initializeStream Http2FrameConnection
conn
                                       Dispatch
dispatch
                                       DispatchControl
control
                                       DispatchStream
newStream
                                       Chan (FrameHeader, FramePayload)
ppWindowsUpdatesChan
                                       Http2Stream -> StreamDefinition b
mkStreamActions
                                       StreamFSMState
ReservedRemote
            ClientIO b
ppCont

    let streamActions :: StreamDefinition a
streamActions = Http2Stream -> StreamDefinition a
getWork (Http2Stream -> StreamDefinition a)
-> Http2Stream -> StreamDefinition a
forall a b. (a -> b) -> a -> b
$ Http2Stream{ClientIO StreamEvent
StreamId -> HeaderList -> PushPromiseHandler -> ClientIO ()
HeaderList -> (FrameFlags -> FrameFlags) -> ClientIO StreamThread
Priority -> ClientIO ()
ErrorCode -> ClientIO ()
(FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
forall {p} {b}.
StreamId
-> p
-> (StreamId
    -> Http2Stream
    -> p
    -> IncomingFlowControl
    -> OutgoingFlowControl
    -> ClientIO b)
-> ClientIO b
_headers :: HeaderList -> (FrameFlags -> FrameFlags) -> ClientIO StreamThread
_prio :: Priority -> ClientIO ()
_rst :: ErrorCode -> ClientIO ()
_waitEvent :: ClientIO StreamEvent
_sendDataChunk :: (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
_handlePushPromise :: StreamId -> HeaderList -> PushPromiseHandler -> ClientIO ()
_headers :: HeaderList -> (FrameFlags -> FrameFlags) -> ClientIO StreamThread
_waitEvent :: ClientIO StreamEvent
_sendDataChunk :: (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
_rst :: ErrorCode -> ClientIO ()
_prio :: Priority -> ClientIO ()
_handlePushPromise :: forall {p} {b}.
StreamId
-> p
-> (StreamId
    -> Http2Stream
    -> p
    -> IncomingFlowControl
    -> OutgoingFlowControl
    -> ClientIO b)
-> ClientIO b
..}

    -- Register handlers for receiving frames and perform the 1st action, the
    -- stream won't be idle anymore.
    Dispatch -> StreamId -> StreamState -> ClientIO ()
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> StreamState -> m ()
registerStream Dispatch
dispatch StreamId
sid (Chan (FrameHeader, FramePayload)
-> Chan StreamEvent -> StreamFSMState -> StreamState
StreamState Chan (FrameHeader, FramePayload)
windowUpdatesChan Chan StreamEvent
events StreamFSMState
initialState)
    StreamThread
_ <- StreamDefinition a -> ClientIO StreamThread
forall a. StreamDefinition a -> ClientIO StreamThread
_initStream StreamDefinition a
streamActions

    -- Returns 2nd action.
    -- We build the flow control contexts in this action outside the exclusive
    -- lock on clientStreamIdMutex will be released.
    ClientIO a -> ClientIO (ClientIO a)
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientIO a -> ClientIO (ClientIO a))
-> ClientIO a -> ClientIO (ClientIO a)
forall a b. (a -> b) -> a -> b
$ do
        let baseIncomingWindowSize :: IO StreamId
baseIncomingWindowSize = Settings -> StreamId
initialWindowSize (Settings -> StreamId)
-> (ConnectionSettings -> Settings)
-> ConnectionSettings
-> StreamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionSettings -> Settings
_clientSettings (ConnectionSettings -> StreamId)
-> IO ConnectionSettings -> IO StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> IO ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
control
        IncomingFlowControl
isfc <- IO IncomingFlowControl
-> ExceptT ClientError IO IncomingFlowControl
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 IncomingFlowControl
 -> ExceptT ClientError IO IncomingFlowControl)
-> IO IncomingFlowControl
-> ExceptT ClientError IO IncomingFlowControl
forall a b. (a -> b) -> a -> b
$ DispatchControl
-> IO StreamId
-> (StreamId -> ClientIO ())
-> IO IncomingFlowControl
newIncomingFlowControl DispatchControl
control IO StreamId
baseIncomingWindowSize (Http2FrameClientStream -> StreamId -> ClientIO ()
sendWindowUpdateFrame Http2FrameClientStream
frameStream)
        let baseOutgoingWindowSize :: IO StreamId
baseOutgoingWindowSize = Settings -> StreamId
initialWindowSize (Settings -> StreamId)
-> (ConnectionSettings -> Settings)
-> ConnectionSettings
-> StreamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionSettings -> Settings
_serverSettings (ConnectionSettings -> StreamId)
-> IO ConnectionSettings -> IO StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> IO ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
control
        OutgoingFlowControl
osfc <- IO OutgoingFlowControl
-> ExceptT ClientError IO OutgoingFlowControl
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 OutgoingFlowControl
 -> ExceptT ClientError IO OutgoingFlowControl)
-> IO OutgoingFlowControl
-> ExceptT ClientError IO OutgoingFlowControl
forall a b. (a -> b) -> a -> b
$ DispatchControl
-> Chan (FrameHeader, FramePayload)
-> IO StreamId
-> IO OutgoingFlowControl
newOutgoingFlowControl DispatchControl
control Chan (FrameHeader, FramePayload)
windowUpdatesChan IO StreamId
baseOutgoingWindowSize
        StreamDefinition a
-> IncomingFlowControl -> OutgoingFlowControl -> ClientIO a
forall a.
StreamDefinition a
-> IncomingFlowControl -> OutgoingFlowControl -> ClientIO a
_handleStream StreamDefinition a
streamActions IncomingFlowControl
isfc OutgoingFlowControl
osfc

dispatchLoop
  :: Http2FrameConnection
  -> Dispatch
  -> DispatchControl
  -> Chan (FrameHeader, FramePayload)
  -> IncomingFlowControl
  -> DispatchHPACK
  -> ClientIO (ClientIO (), ClientIO Bool)
dispatchLoop :: Http2FrameConnection
-> Dispatch
-> DispatchControl
-> Chan (FrameHeader, FramePayload)
-> IncomingFlowControl
-> DispatchHPACK
-> ClientIO (ClientIO (), ClientIO Bool)
dispatchLoop Http2FrameConnection
conn Dispatch
d DispatchControl
dc Chan (FrameHeader, FramePayload)
windowUpdatesChan IncomingFlowControl
inFlowControl DispatchHPACK
dh = do
    let getNextFrame :: ClientIO (FrameHeader, Either FrameDecodeError FramePayload)
getNextFrame = Http2FrameConnection
-> ClientIO (FrameHeader, Either FrameDecodeError FramePayload)
next Http2FrameConnection
conn
    let go :: ClientIO a
go = ClientIO a -> ClientIO a
forall a. ClientIO a -> ClientIO a
delayException (ClientIO a -> ClientIO a)
-> (ClientIO () -> ClientIO a) -> ClientIO () -> ClientIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientIO () -> ClientIO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ClientIO () -> ClientIO a) -> ClientIO () -> ClientIO a
forall a b. (a -> b) -> a -> b
$ do
            (FrameHeader, Either FrameDecodeError FramePayload)
frame <- ClientIO (FrameHeader, Either FrameDecodeError FramePayload)
getNextFrame
            (FrameHeader, Either FrameDecodeError FramePayload)
-> Dispatch -> ClientIO ()
dispatchFramesStep (FrameHeader, Either FrameDecodeError FramePayload)
frame Dispatch
d
            (FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either FrameDecodeError FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
forall e.
Exception e =>
(FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either e FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
whenFrame (StreamId -> FrameHeader -> FramePayload -> Bool
hasStreamId StreamId
0) (FrameHeader, Either FrameDecodeError FramePayload)
frame (FallBackFrameHandler -> ClientIO ())
-> FallBackFrameHandler -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ \(FrameHeader, FramePayload)
got ->
                Chan (FrameHeader, FramePayload)
-> (FrameHeader, FramePayload) -> DispatchControl -> ClientIO ()
dispatchControlFramesStep Chan (FrameHeader, FramePayload)
windowUpdatesChan (FrameHeader, FramePayload)
got DispatchControl
dc
            (FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either FrameDecodeError FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
forall e.
Exception e =>
(FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either e FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
whenFrame ([FrameType] -> FrameHeader -> FramePayload -> Bool
hasTypeId [FrameType
FrameData]) (FrameHeader, Either FrameDecodeError FramePayload)
frame (FallBackFrameHandler -> ClientIO ())
-> FallBackFrameHandler -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ \(FrameHeader, FramePayload)
got ->
                Dispatch -> IncomingFlowControl -> FallBackFrameHandler
creditDataFramesStep Dispatch
d IncomingFlowControl
inFlowControl (FrameHeader, FramePayload)
got
            (FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either FrameDecodeError FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
forall e.
Exception e =>
(FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either e FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
whenFrame ([FrameType] -> FrameHeader -> FramePayload -> Bool
hasTypeId [FrameType
FrameWindowUpdate]) (FrameHeader, Either FrameDecodeError FramePayload)
frame (FallBackFrameHandler -> ClientIO ())
-> FallBackFrameHandler -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ \(FrameHeader, FramePayload)
got -> do
                Dispatch -> FallBackFrameHandler
updateWindowsStep Dispatch
d (FrameHeader, FramePayload)
got
            (FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either FrameDecodeError FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
forall e.
Exception e =>
(FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either e FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
whenFrame ([FrameType] -> FrameHeader -> FramePayload -> Bool
hasTypeId [FrameType
FramePushPromise, FrameType
FrameHeaders]) (FrameHeader, Either FrameDecodeError FramePayload)
frame (FallBackFrameHandler -> ClientIO ())
-> FallBackFrameHandler -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ \(FrameHeader, FramePayload)
got -> do
                let hpackLoop :: HPACKStepResult -> ClientIO ()
hpackLoop (FinishedWithHeaders FrameHeader
curFh StreamId
sId IO HeaderList
mkNewHdrs) = IO () -> ClientIO ()
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 () -> ClientIO ()) -> IO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ do
                        HeaderList
newHdrs <- IO HeaderList
mkNewHdrs
                        Maybe (Chan StreamEvent)
chan <- (StreamState -> Chan StreamEvent)
-> Maybe StreamState -> Maybe (Chan StreamEvent)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StreamState -> Chan StreamEvent
_streamStateEvents (Maybe StreamState -> Maybe (Chan StreamEvent))
-> IO (Maybe StreamState) -> IO (Maybe (Chan StreamEvent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dispatch -> StreamId -> IO (Maybe StreamState)
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m (Maybe StreamState)
lookupStreamState Dispatch
d StreamId
sId
                        let msg :: StreamEvent
msg = FrameHeader -> HeaderList -> StreamEvent
StreamHeadersEvent FrameHeader
curFh HeaderList
newHdrs
                        IO ()
-> (Chan StreamEvent -> IO ()) -> Maybe (Chan StreamEvent) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Chan StreamEvent -> StreamEvent -> IO ())
-> StreamEvent -> Chan StreamEvent -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Chan StreamEvent -> StreamEvent -> IO ()
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan StreamEvent
msg) Maybe (Chan StreamEvent)
chan
                    hpackLoop (FinishedWithPushPromise FrameHeader
curFh StreamId
parentSid StreamId
newSid IO HeaderList
mkNewHdrs) = IO () -> ClientIO ()
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 () -> ClientIO ()) -> IO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ do
                        HeaderList
newHdrs <- IO HeaderList
mkNewHdrs
                        Maybe (Chan StreamEvent)
chan <- (StreamState -> Chan StreamEvent)
-> Maybe StreamState -> Maybe (Chan StreamEvent)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StreamState -> Chan StreamEvent
_streamStateEvents (Maybe StreamState -> Maybe (Chan StreamEvent))
-> IO (Maybe StreamState) -> IO (Maybe (Chan StreamEvent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dispatch -> StreamId -> IO (Maybe StreamState)
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m (Maybe StreamState)
lookupStreamState Dispatch
d StreamId
parentSid
                        let msg :: StreamEvent
msg = FrameHeader -> StreamId -> HeaderList -> StreamEvent
StreamPushPromiseEvent FrameHeader
curFh StreamId
newSid HeaderList
newHdrs
                        IO ()
-> (Chan StreamEvent -> IO ()) -> Maybe (Chan StreamEvent) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Chan StreamEvent -> StreamEvent -> IO ())
-> StreamEvent -> Chan StreamEvent -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Chan StreamEvent -> StreamEvent -> IO ()
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan StreamEvent
msg) Maybe (Chan StreamEvent)
chan
                    hpackLoop (WaitContinuation (FrameHeader, Either FrameDecodeError FramePayload)
-> ClientIO HPACKStepResult
act)        =
                        ClientIO (FrameHeader, Either FrameDecodeError FramePayload)
getNextFrame ClientIO (FrameHeader, Either FrameDecodeError FramePayload)
-> ((FrameHeader, Either FrameDecodeError FramePayload)
    -> ClientIO HPACKStepResult)
-> ClientIO HPACKStepResult
forall a b.
ExceptT ClientError IO a
-> (a -> ExceptT ClientError IO b) -> ExceptT ClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FrameHeader, Either FrameDecodeError FramePayload)
-> ClientIO HPACKStepResult
act ClientIO HPACKStepResult
-> (HPACKStepResult -> ClientIO ()) -> ClientIO ()
forall a b.
ExceptT ClientError IO a
-> (a -> ExceptT ClientError IO b) -> ExceptT ClientError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HPACKStepResult -> ClientIO ()
hpackLoop
                    hpackLoop (FailedHeaders FrameHeader
curFh StreamId
sId ErrorCode
err)        = IO () -> ClientIO ()
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 () -> ClientIO ()) -> IO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ do
                        Maybe (Chan StreamEvent)
chan <- (StreamState -> Chan StreamEvent)
-> Maybe StreamState -> Maybe (Chan StreamEvent)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StreamState -> Chan StreamEvent
_streamStateEvents (Maybe StreamState -> Maybe (Chan StreamEvent))
-> IO (Maybe StreamState) -> IO (Maybe (Chan StreamEvent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dispatch -> StreamId -> IO (Maybe StreamState)
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m (Maybe StreamState)
lookupStreamState Dispatch
d StreamId
sId
                        let msg :: StreamEvent
msg = FrameHeader -> ErrorCode -> StreamEvent
StreamErrorEvent FrameHeader
curFh ErrorCode
err
                        IO ()
-> (Chan StreamEvent -> IO ()) -> Maybe (Chan StreamEvent) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Chan StreamEvent -> StreamEvent -> IO ())
-> StreamEvent -> Chan StreamEvent -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Chan StreamEvent -> StreamEvent -> IO ()
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan StreamEvent
msg) Maybe (Chan StreamEvent)
chan
                HPACKStepResult -> ClientIO ()
hpackLoop ((FrameHeader, FramePayload) -> DispatchHPACK -> HPACKStepResult
dispatchHPACKFramesStep (FrameHeader, FramePayload)
got DispatchHPACK
dh)
            (FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either FrameDecodeError FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
forall e.
Exception e =>
(FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either e FramePayload)
-> FallBackFrameHandler
-> ClientIO ()
whenFrame ([FrameType] -> FrameHeader -> FramePayload -> Bool
hasTypeId [FrameType
FrameRSTStream]) (FrameHeader, Either FrameDecodeError FramePayload)
frame (FallBackFrameHandler -> ClientIO ())
-> FallBackFrameHandler -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ \(FrameHeader, FramePayload)
got -> do
                Dispatch -> FallBackFrameHandler
handleRSTStep Dispatch
d (FrameHeader, FramePayload)
got
            (FrameHeader, Either FrameDecodeError FramePayload)
-> Dispatch -> ClientIO ()
finalizeFramesStep (FrameHeader, Either FrameDecodeError FramePayload)
frame Dispatch
d
    MVar ()
end <- ExceptT ClientError IO (MVar ())
forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
    let run :: ClientIO ()
run = ExceptT ClientError IO (Either Any ()) -> ClientIO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ClientError IO (Either Any ()) -> ClientIO ())
-> ExceptT ClientError IO (Either Any ()) -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ ExceptT ClientError IO Any
-> ClientIO () -> ExceptT ClientError IO (Either Any ())
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m (Either a b)
race ExceptT ClientError IO Any
forall {a}. ClientIO a
go (MVar () -> ClientIO ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
takeMVar MVar ()
end)
    let stop :: ClientIO Bool
stop = MVar () -> () -> ClientIO Bool
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m Bool
tryPutMVar MVar ()
end ()
    (ClientIO (), ClientIO Bool)
-> ClientIO (ClientIO (), ClientIO Bool)
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientIO ()
run, ClientIO Bool
stop)

handleRSTStep
  :: Dispatch
  -> (FrameHeader, FramePayload)
  -> ClientIO ()
handleRSTStep :: Dispatch -> FallBackFrameHandler
handleRSTStep Dispatch
d (FrameHeader
fh, FramePayload
payload) = do
    let sid :: StreamId
sid = FrameHeader -> StreamId
streamId FrameHeader
fh
    case FramePayload
payload of
        (RSTStreamFrame ErrorCode
err) -> IO () -> ClientIO ()
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 () -> ClientIO ()) -> IO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ do
            Maybe (Chan StreamEvent)
chan <- (StreamState -> Chan StreamEvent)
-> Maybe StreamState -> Maybe (Chan StreamEvent)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StreamState -> Chan StreamEvent
_streamStateEvents (Maybe StreamState -> Maybe (Chan StreamEvent))
-> IO (Maybe StreamState) -> IO (Maybe (Chan StreamEvent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dispatch -> StreamId -> IO (Maybe StreamState)
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m (Maybe StreamState)
lookupStreamState Dispatch
d StreamId
sid
            let msg :: StreamEvent
msg = FrameHeader -> ErrorCode -> StreamEvent
StreamErrorEvent FrameHeader
fh ErrorCode
err
            IO ()
-> (Chan StreamEvent -> IO ()) -> Maybe (Chan StreamEvent) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Chan StreamEvent -> StreamEvent -> IO ())
-> StreamEvent -> Chan StreamEvent -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Chan StreamEvent -> StreamEvent -> IO ()
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan StreamEvent
msg) Maybe (Chan StreamEvent)
chan
            Dispatch -> StreamId -> IO ()
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m ()
closeReleaseStream Dispatch
d StreamId
sid
        FramePayload
_ ->
            [Char] -> ClientIO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> ClientIO ()) -> [Char] -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"expecting RSTFrame but got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FramePayload -> [Char]
forall a. Show a => a -> [Char]
show FramePayload
payload

dispatchFramesStep
  :: (FrameHeader, Either FrameDecodeError FramePayload)
  -> Dispatch
  -> ClientIO ()
dispatchFramesStep :: (FrameHeader, Either FrameDecodeError FramePayload)
-> Dispatch -> ClientIO ()
dispatchFramesStep (FrameHeader
fh,Either FrameDecodeError FramePayload
_) Dispatch
d = do
    let sid :: StreamId
sid = FrameHeader -> StreamId
streamId FrameHeader
fh
    -- Remember highest streamId.
    IORef StreamId -> (StreamId -> (StreamId, ())) -> ClientIO ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (Dispatch -> IORef StreamId
_dispatchMaxStreamId Dispatch
d) (\StreamId
n -> (StreamId -> StreamId -> StreamId
forall a. Ord a => a -> a -> a
max StreamId
n StreamId
sid, ()))

finalizeFramesStep
  :: (FrameHeader, Either FrameDecodeError FramePayload)
  -> Dispatch
  -> ClientIO ()
finalizeFramesStep :: (FrameHeader, Either FrameDecodeError FramePayload)
-> Dispatch -> ClientIO ()
finalizeFramesStep (FrameHeader
fh,Either FrameDecodeError FramePayload
_) Dispatch
d = do
    let sid :: StreamId
sid = FrameHeader -> StreamId
streamId FrameHeader
fh
    -- Remote-close streams that match.
    Bool -> ClientIO () -> ClientIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameFlags -> Bool
testEndStream (FrameFlags -> Bool) -> FrameFlags -> Bool
forall a b. (a -> b) -> a -> b
$ FrameHeader -> FrameFlags
flags FrameHeader
fh) (ClientIO () -> ClientIO ()) -> ClientIO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ do
        Dispatch -> StreamId -> ClientIO ()
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m ()
closeRemoteStream Dispatch
d StreamId
sid

dispatchControlFramesStep
  :: Chan (FrameHeader, FramePayload)
  -> (FrameHeader, FramePayload)
  -> DispatchControl
  -> ClientIO ()
dispatchControlFramesStep :: Chan (FrameHeader, FramePayload)
-> (FrameHeader, FramePayload) -> DispatchControl -> ClientIO ()
dispatchControlFramesStep Chan (FrameHeader, FramePayload)
windowUpdatesChan controlFrame :: (FrameHeader, FramePayload)
controlFrame@(FrameHeader
fh, FramePayload
payload) control :: DispatchControl
control@(DispatchControl{IORef [(ByteString, PingHandler)]
IORef [SetSettingsHandler]
IORef ConnectionSettings
ClientIO ()
HpackEncoderContext
FallBackFrameHandler
ByteString -> ClientIO ()
GoAwayHandler
_dispatchControlHpackEncoder :: DispatchControl -> HpackEncoderContext
_dispatchControlConnectionSettings :: IORef ConnectionSettings
_dispatchControlHpackEncoder :: HpackEncoderContext
_dispatchControlAckPing :: ByteString -> ClientIO ()
_dispatchControlAckSettings :: ClientIO ()
_dispatchControlOnGoAway :: GoAwayHandler
_dispatchControlOnFallback :: FallBackFrameHandler
_dispatchControlPingHandlers :: IORef [(ByteString, PingHandler)]
_dispatchControlSetSettingsHandlers :: IORef [SetSettingsHandler]
_dispatchControlConnectionSettings :: DispatchControl -> IORef ConnectionSettings
_dispatchControlAckPing :: DispatchControl -> ByteString -> ClientIO ()
_dispatchControlAckSettings :: DispatchControl -> ClientIO ()
_dispatchControlOnGoAway :: DispatchControl -> GoAwayHandler
_dispatchControlOnFallback :: DispatchControl -> FallBackFrameHandler
_dispatchControlPingHandlers :: DispatchControl -> IORef [(ByteString, PingHandler)]
_dispatchControlSetSettingsHandlers :: DispatchControl -> IORef [SetSettingsHandler]
..}) = do
    case FramePayload
payload of
        (SettingsFrame SettingsList
settsList)
            | Bool -> Bool
not (Bool -> Bool) -> (FrameHeader -> Bool) -> FrameHeader -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameFlags -> Bool
testAck (FrameFlags -> Bool)
-> (FrameHeader -> FrameFlags) -> FrameHeader -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameHeader -> FrameFlags
flags (FrameHeader -> Bool) -> FrameHeader -> Bool
forall a b. (a -> b) -> a -> b
$ FrameHeader
fh -> do
                IORef ConnectionSettings
-> (ConnectionSettings -> (ConnectionSettings, ())) -> ClientIO ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef ConnectionSettings
_dispatchControlConnectionSettings
                                   (\(ConnectionSettings Settings
cli Settings
srv) ->
                                      (Settings -> Settings -> ConnectionSettings
ConnectionSettings Settings
cli (Settings -> SettingsList -> Settings
HTTP2.updateSettings Settings
srv SettingsList
settsList), ()))
                IO () -> ClientIO ()
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 () -> ClientIO ()) -> IO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (StreamId -> IO ()) -> Maybe StreamId -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                      (HpackEncoderContext -> StreamId -> IO ()
_applySettings HpackEncoderContext
_dispatchControlHpackEncoder)
                      (SettingsKey -> SettingsList -> Maybe StreamId
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsHeaderTableSize SettingsList
settsList)
                ClientIO ()
_dispatchControlAckSettings
            | Bool
otherwise                 -> do
                Maybe SetSettingsHandler
handler <- DispatchControl
-> ExceptT ClientError IO (Maybe SetSettingsHandler)
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m (Maybe SetSettingsHandler)
lookupAndReleaseSetSettingsHandler DispatchControl
control
                ClientIO ()
-> (SetSettingsHandler -> ClientIO ())
-> Maybe SetSettingsHandler
-> ClientIO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ClientIO ()
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((FrameHeader, FramePayload) -> SetSettingsHandler -> ClientIO ()
forall (m :: * -> *).
MonadBase IO m =>
(FrameHeader, FramePayload) -> SetSettingsHandler -> m ()
notifySetSettingsHandler (FrameHeader, FramePayload)
controlFrame) Maybe SetSettingsHandler
handler
        (PingFrame ByteString
pingMsg)
            | Bool -> Bool
not (Bool -> Bool) -> (FrameHeader -> Bool) -> FrameHeader -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameFlags -> Bool
testAck (FrameFlags -> Bool)
-> (FrameHeader -> FrameFlags) -> FrameHeader -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameHeader -> FrameFlags
flags (FrameHeader -> Bool) -> FrameHeader -> Bool
forall a b. (a -> b) -> a -> b
$ FrameHeader
fh ->
                ByteString -> ClientIO ()
_dispatchControlAckPing ByteString
pingMsg
            | Bool
otherwise                 -> do
                Maybe PingHandler
handler <- DispatchControl
-> ByteString -> ExceptT ClientError IO (Maybe PingHandler)
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> ByteString -> m (Maybe PingHandler)
lookupAndReleasePingHandler DispatchControl
control ByteString
pingMsg
                ClientIO ()
-> (PingHandler -> ClientIO ()) -> Maybe PingHandler -> ClientIO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ClientIO ()
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((FrameHeader, FramePayload) -> PingHandler -> ClientIO ()
forall (m :: * -> *).
MonadBase IO m =>
(FrameHeader, FramePayload) -> PingHandler -> m ()
notifyPingHandler (FrameHeader, FramePayload)
controlFrame) Maybe PingHandler
handler
        (WindowUpdateFrame StreamId
_ )  ->
                Chan (FrameHeader, FramePayload) -> FallBackFrameHandler
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan Chan (FrameHeader, FramePayload)
windowUpdatesChan (FrameHeader, FramePayload)
controlFrame
        (GoAwayFrame StreamId
lastSid ErrorCode
errCode ByteString
reason)  ->
             GoAwayHandler
_dispatchControlOnGoAway GoAwayHandler -> GoAwayHandler
forall a b. (a -> b) -> a -> b
$ StreamId -> ErrorCode -> ByteString -> RemoteSentGoAwayFrame
RemoteSentGoAwayFrame StreamId
lastSid ErrorCode
errCode ByteString
reason

        FramePayload
_                   ->
             FallBackFrameHandler
_dispatchControlOnFallback (FrameHeader, FramePayload)
controlFrame

-- | We currently need a specific step in the main loop for crediting streams
-- because a client user may programmatically reset and stop listening for a
-- stream and stop calling waitData (which credits streams).
--
-- TODO: modify the '_rst' function to wait and credit all the remaining data
-- that could have been sent in flight
creditDataFramesStep
  :: Dispatch
  -> IncomingFlowControl
  -> (FrameHeader, FramePayload)
  -> ClientIO ()
creditDataFramesStep :: Dispatch -> IncomingFlowControl -> FallBackFrameHandler
creditDataFramesStep Dispatch
d IncomingFlowControl
flowControl (FrameHeader
fh,FramePayload
payload) = do
    -- TODO: error if detect over-run. Current implementation credits
    -- everything back. Hence, over-run should never happen.
    StreamId
_ <- IO StreamId -> ClientIO StreamId
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 StreamId -> ClientIO StreamId)
-> IO StreamId -> ClientIO StreamId
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl -> StreamId -> IO StreamId
_consumeCredit IncomingFlowControl
flowControl (FrameHeader -> StreamId
HTTP2.payloadLength FrameHeader
fh)
    IO () -> ClientIO ()
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 () -> ClientIO ()) -> IO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl -> StreamId -> IO ()
_addCredit IncomingFlowControl
flowControl (FrameHeader -> StreamId
HTTP2.payloadLength FrameHeader
fh)

    -- Write to the interested streams.
    let sid :: StreamId
sid = FrameHeader -> StreamId
streamId FrameHeader
fh
    case FramePayload
payload of
        (DataFrame ByteString
dat) -> do
            Maybe (Chan StreamEvent)
chan <- (StreamState -> Chan StreamEvent)
-> Maybe StreamState -> Maybe (Chan StreamEvent)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StreamState -> Chan StreamEvent
_streamStateEvents (Maybe StreamState -> Maybe (Chan StreamEvent))
-> ExceptT ClientError IO (Maybe StreamState)
-> ExceptT ClientError IO (Maybe (Chan StreamEvent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dispatch -> StreamId -> ExceptT ClientError IO (Maybe StreamState)
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m (Maybe StreamState)
lookupStreamState Dispatch
d StreamId
sid
            ClientIO ()
-> (Chan StreamEvent -> ClientIO ())
-> Maybe (Chan StreamEvent)
-> ClientIO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ClientIO ()
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Chan StreamEvent -> StreamEvent -> ClientIO ())
-> StreamEvent -> Chan StreamEvent -> ClientIO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Chan StreamEvent -> StreamEvent -> ClientIO ()
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan (StreamEvent -> Chan StreamEvent -> ClientIO ())
-> StreamEvent -> Chan StreamEvent -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ FrameHeader -> ByteString -> StreamEvent
StreamDataEvent FrameHeader
fh ByteString
dat) Maybe (Chan StreamEvent)
chan
        FramePayload
_ ->
            [Char] -> ClientIO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> ClientIO ()) -> [Char] -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"expecting DataFrame but got " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FramePayload -> [Char]
forall a. Show a => a -> [Char]
show FramePayload
payload

updateWindowsStep
  :: Dispatch
  -> (FrameHeader, FramePayload)
  -> ClientIO ()
updateWindowsStep :: Dispatch -> FallBackFrameHandler
updateWindowsStep Dispatch
d got :: (FrameHeader, FramePayload)
got@(FrameHeader
fh,FramePayload
_) = do
    let sid :: StreamId
sid = FrameHeader -> StreamId
HTTP2.streamId FrameHeader
fh
    Maybe (Chan (FrameHeader, FramePayload))
chan <- (StreamState -> Chan (FrameHeader, FramePayload))
-> Maybe StreamState -> Maybe (Chan (FrameHeader, FramePayload))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StreamState -> Chan (FrameHeader, FramePayload)
_streamStateWindowUpdatesChan (Maybe StreamState -> Maybe (Chan (FrameHeader, FramePayload)))
-> ExceptT ClientError IO (Maybe StreamState)
-> ExceptT
     ClientError IO (Maybe (Chan (FrameHeader, FramePayload)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dispatch -> StreamId -> ExceptT ClientError IO (Maybe StreamState)
forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> StreamId -> m (Maybe StreamState)
lookupStreamState Dispatch
d StreamId
sid
    ClientIO ()
-> (Chan (FrameHeader, FramePayload) -> ClientIO ())
-> Maybe (Chan (FrameHeader, FramePayload))
-> ClientIO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ClientIO ()
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Chan (FrameHeader, FramePayload) -> FallBackFrameHandler)
-> (FrameHeader, FramePayload)
-> Chan (FrameHeader, FramePayload)
-> ClientIO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Chan (FrameHeader, FramePayload) -> FallBackFrameHandler
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan (FrameHeader, FramePayload)
got) Maybe (Chan (FrameHeader, FramePayload))
chan --TODO: refer to RFC for erroring on idle/closed streams

data HPACKLoopDecision =
    ForwardHeader !StreamId
  | OpenPushPromise !StreamId !StreamId

data HPACKStepResult =
    WaitContinuation !((FrameHeader, Either FrameDecodeError FramePayload) -> ClientIO HPACKStepResult)
  | FailedHeaders !FrameHeader !StreamId ErrorCode
  | FinishedWithHeaders !FrameHeader !StreamId (IO HeaderList)
  | FinishedWithPushPromise !FrameHeader !StreamId !StreamId (IO HeaderList)

dispatchHPACKFramesStep
  :: (FrameHeader, FramePayload)
  -> DispatchHPACK
  -> HPACKStepResult
dispatchHPACKFramesStep :: (FrameHeader, FramePayload) -> DispatchHPACK -> HPACKStepResult
dispatchHPACKFramesStep (FrameHeader
fh,FramePayload
fp) (DispatchHPACK{DynamicTable
_dispatchHPACKDynamicTable :: DynamicTable
_dispatchHPACKDynamicTable :: DispatchHPACK -> DynamicTable
..}) =
    let (HPACKLoopDecision
decision, Either ErrorCode ByteString
pattern) = case FramePayload
fp of
            PushPromiseFrame StreamId
ppSid ByteString
hbf -> do
                (StreamId -> StreamId -> HPACKLoopDecision
OpenPushPromise StreamId
sid StreamId
ppSid, ByteString -> Either ErrorCode ByteString
forall a b. b -> Either a b
Right ByteString
hbf)
            HeadersFrame Maybe Priority
_ ByteString
hbf       -> -- TODO: handle priority
                (StreamId -> HPACKLoopDecision
ForwardHeader StreamId
sid, ByteString -> Either ErrorCode ByteString
forall a b. b -> Either a b
Right ByteString
hbf)
            RSTStreamFrame ErrorCode
err       ->
                (StreamId -> HPACKLoopDecision
ForwardHeader StreamId
sid, ErrorCode -> Either ErrorCode ByteString
forall a b. a -> Either a b
Left ErrorCode
err)
            FramePayload
_                        ->
                [Char] -> (HPACKLoopDecision, Either ErrorCode ByteString)
forall a. HasCallStack => [Char] -> a
error [Char]
"wrong TypeId"
    in FrameHeader
-> HPACKLoopDecision
-> Either ErrorCode ByteString
-> HPACKStepResult
go FrameHeader
fh HPACKLoopDecision
decision Either ErrorCode ByteString
pattern
  where
    sid :: StreamId
    sid :: StreamId
sid = FrameHeader -> StreamId
HTTP2.streamId FrameHeader
fh

    go :: FrameHeader -> HPACKLoopDecision -> Either ErrorCode ByteString -> HPACKStepResult
    go :: FrameHeader
-> HPACKLoopDecision
-> Either ErrorCode ByteString
-> HPACKStepResult
go FrameHeader
curFh HPACKLoopDecision
decision (Right ByteString
buffer) =
        if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FrameFlags -> Bool
HTTP2.testEndHeader (FrameHeader -> FrameFlags
HTTP2.flags FrameHeader
curFh)
        then ((FrameHeader, Either FrameDecodeError FramePayload)
 -> ClientIO HPACKStepResult)
-> HPACKStepResult
WaitContinuation (((FrameHeader, Either FrameDecodeError FramePayload)
  -> ClientIO HPACKStepResult)
 -> HPACKStepResult)
-> ((FrameHeader, Either FrameDecodeError FramePayload)
    -> ClientIO HPACKStepResult)
-> HPACKStepResult
forall a b. (a -> b) -> a -> b
$ \(FrameHeader, Either FrameDecodeError FramePayload)
frame -> do
            let interrupted :: FrameHeader -> FramePayload -> Bool
interrupted FrameHeader
fh2 FramePayload
fp2 =
                    Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [FrameType] -> FrameHeader -> FramePayload -> Bool
hasTypeId [ FrameType
FrameRSTStream , FrameType
FrameContinuation ] FrameHeader
fh2 FramePayload
fp2
            (FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either FrameDecodeError FramePayload)
-> ((FrameHeader, FramePayload) -> ClientIO HPACKStepResult)
-> ((FrameHeader, FramePayload) -> ClientIO HPACKStepResult)
-> ClientIO HPACKStepResult
forall e a.
Exception e =>
(FrameHeader -> FramePayload -> Bool)
-> (FrameHeader, Either e FramePayload)
-> ((FrameHeader, FramePayload) -> ClientIO a)
-> ((FrameHeader, FramePayload) -> ClientIO a)
-> ClientIO a
whenFrameElse FrameHeader -> FramePayload -> Bool
interrupted (FrameHeader, Either FrameDecodeError FramePayload)
frame (\(FrameHeader, FramePayload)
_ ->
                [Char] -> ClientIO HPACKStepResult
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid frame type while waiting for CONTINUATION")
                                            (\(FrameHeader
lastFh, FramePayload
lastFp) ->
                case FramePayload
lastFp of
                    ContinuationFrame ByteString
chbf ->
                        HPACKStepResult -> ClientIO HPACKStepResult
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HPACKStepResult -> ClientIO HPACKStepResult)
-> HPACKStepResult -> ClientIO HPACKStepResult
forall a b. (a -> b) -> a -> b
$ FrameHeader
-> HPACKLoopDecision
-> Either ErrorCode ByteString
-> HPACKStepResult
go FrameHeader
lastFh HPACKLoopDecision
decision (ByteString -> Either ErrorCode ByteString
forall a b. b -> Either a b
Right (ByteString -> ByteString -> ByteString
ByteString.append ByteString
buffer ByteString
chbf))
                    RSTStreamFrame ErrorCode
err     ->
                        HPACKStepResult -> ClientIO HPACKStepResult
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HPACKStepResult -> ClientIO HPACKStepResult)
-> HPACKStepResult -> ClientIO HPACKStepResult
forall a b. (a -> b) -> a -> b
$ FrameHeader
-> HPACKLoopDecision
-> Either ErrorCode ByteString
-> HPACKStepResult
go FrameHeader
lastFh HPACKLoopDecision
decision (ErrorCode -> Either ErrorCode ByteString
forall a b. a -> Either a b
Left ErrorCode
err)
                    FramePayload
_                     ->
                        [Char] -> ClientIO HPACKStepResult
forall a. HasCallStack => [Char] -> a
error [Char]
"continued frame has invalid type")
        else case HPACKLoopDecision
decision of
            ForwardHeader StreamId
sId ->
                FrameHeader -> StreamId -> IO HeaderList -> HPACKStepResult
FinishedWithHeaders FrameHeader
curFh StreamId
sId (DynamicTable -> ByteString -> IO HeaderList
decodeHeader DynamicTable
_dispatchHPACKDynamicTable ByteString
buffer)
            OpenPushPromise StreamId
parentSid StreamId
newSid ->
                FrameHeader
-> StreamId -> StreamId -> IO HeaderList -> HPACKStepResult
FinishedWithPushPromise FrameHeader
curFh StreamId
parentSid StreamId
newSid (DynamicTable -> ByteString -> IO HeaderList
decodeHeader DynamicTable
_dispatchHPACKDynamicTable ByteString
buffer)
    go FrameHeader
curFh HPACKLoopDecision
_ (Left ErrorCode
err) =
        FrameHeader -> StreamId -> ErrorCode -> HPACKStepResult
FailedHeaders FrameHeader
curFh StreamId
sid ErrorCode
err


newIncomingFlowControl
  :: DispatchControl
  -> IO Int
  -- ^ Action to get the base window size.
  -> (WindowSize -> ClientIO ())
  -- ^ Action to send the window update to the server.
  -> IO IncomingFlowControl
newIncomingFlowControl :: DispatchControl
-> IO StreamId
-> (StreamId -> ClientIO ())
-> IO IncomingFlowControl
newIncomingFlowControl DispatchControl
control IO StreamId
getBase StreamId -> ClientIO ()
doSendUpdate = do
    IORef StreamId
creditAdded <- StreamId -> IO (IORef StreamId)
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef StreamId
0
    IORef StreamId
creditConsumed <- StreamId -> IO (IORef StreamId)
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef StreamId
0
    let _addCredit :: StreamId -> m ()
_addCredit StreamId
n = IORef StreamId -> (StreamId -> (StreamId, ())) -> m ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef StreamId
creditAdded (\StreamId
c -> (StreamId
c StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
n, ()))
    let _consumeCredit :: StreamId -> IO StreamId
_consumeCredit StreamId
n = do
            StreamId
conso <- IORef StreamId -> (StreamId -> (StreamId, StreamId)) -> IO StreamId
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef StreamId
creditConsumed (\StreamId
c -> (StreamId
c StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
n, StreamId
c StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
n))
            StreamId
base <- IO StreamId
getBase
            StreamId
extra <- IORef StreamId -> IO StreamId
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef StreamId
creditAdded
            StreamId -> IO StreamId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamId -> IO StreamId) -> StreamId -> IO StreamId
forall a b. (a -> b) -> a -> b
$ StreamId
base StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
extra StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
- StreamId
conso
    let _updateWindow :: ClientIO Bool
_updateWindow = do
            StreamId
base <- Settings -> StreamId
initialWindowSize (Settings -> StreamId)
-> (ConnectionSettings -> Settings)
-> ConnectionSettings
-> StreamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionSettings -> Settings
_clientSettings (ConnectionSettings -> StreamId)
-> ExceptT ClientError IO ConnectionSettings -> ClientIO StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> ExceptT ClientError IO ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
control
            StreamId
added <- IORef StreamId -> ClientIO StreamId
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef StreamId
creditAdded
            StreamId
consumed <- IORef StreamId -> ClientIO StreamId
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef StreamId
creditConsumed

            let transferred :: StreamId
transferred = StreamId -> StreamId -> StreamId
forall a. Ord a => a -> a -> a
min StreamId
added (StreamId
HTTP2.maxWindowSize StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
- StreamId
base StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
consumed)
            let shouldUpdate :: Bool
shouldUpdate = StreamId
transferred StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
0

            StreamId -> ClientIO ()
forall {m :: * -> *}. MonadBase IO m => StreamId -> m ()
_addCredit (StreamId -> StreamId
forall a. Num a => a -> a
negate StreamId
transferred)
            StreamId
_ <- IO StreamId -> ClientIO StreamId
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 StreamId -> ClientIO StreamId)
-> IO StreamId -> ClientIO StreamId
forall a b. (a -> b) -> a -> b
$ StreamId -> IO StreamId
_consumeCredit (StreamId -> StreamId
forall a. Num a => a -> a
negate StreamId
transferred)
            Bool -> ClientIO () -> ClientIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldUpdate (StreamId -> ClientIO ()
doSendUpdate StreamId
transferred)

            Bool -> ClientIO Bool
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
shouldUpdate
    IncomingFlowControl -> IO IncomingFlowControl
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IncomingFlowControl -> IO IncomingFlowControl)
-> IncomingFlowControl -> IO IncomingFlowControl
forall a b. (a -> b) -> a -> b
$ (StreamId -> IO ())
-> (StreamId -> IO StreamId)
-> ClientIO Bool
-> IncomingFlowControl
IncomingFlowControl StreamId -> IO ()
forall {m :: * -> *}. MonadBase IO m => StreamId -> m ()
_addCredit StreamId -> IO StreamId
_consumeCredit ClientIO Bool
_updateWindow

newOutgoingFlowControl ::
     DispatchControl
  -- ^ Control dispatching reference.
  -> Chan (FrameHeader, FramePayload)
  -> IO Int
  -- ^ Action to get the instantaneous base window-size.
  -> IO OutgoingFlowControl
newOutgoingFlowControl :: DispatchControl
-> Chan (FrameHeader, FramePayload)
-> IO StreamId
-> IO OutgoingFlowControl
newOutgoingFlowControl DispatchControl
control Chan (FrameHeader, FramePayload)
frames IO StreamId
getBase = do
    IORef StreamId
credit <- StreamId -> IO (IORef StreamId)
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef StreamId
0
    let receive :: StreamId -> m ()
receive StreamId
n = IORef StreamId -> (StreamId -> (StreamId, ())) -> m ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef StreamId
credit (\StreamId
c -> (StreamId
c StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
n, ()))
    let withdraw :: StreamId -> t IO StreamId
withdraw StreamId
0 = StreamId -> t IO StreamId
forall a. a -> t IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamId
0
        withdraw StreamId
n = do
            StreamId
base <- IO StreamId -> t IO StreamId
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO StreamId
getBase
            StreamId
got <- IORef StreamId
-> (StreamId -> (StreamId, StreamId)) -> t IO StreamId
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef StreamId
credit (\StreamId
c ->
                    if StreamId
base StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
c StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
>= StreamId
n
                    then (StreamId
c StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
- StreamId
n, StreamId
n)
                    else (StreamId
0 StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
- StreamId
base, StreamId
base StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
+ StreamId
c))
            if StreamId
got StreamId -> StreamId -> Bool
forall a. Ord a => a -> a -> Bool
> StreamId
0
            then StreamId -> t IO StreamId
forall a. a -> t IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamId
got
            else do
                Either () StreamId
amount <- t IO () -> t IO StreamId -> t IO (Either () StreamId)
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m (Either a b)
race (StreamId -> t IO ()
forall {m :: * -> *}. MonadBase IO m => StreamId -> m ()
waitSettingsChange StreamId
base) (Chan (FrameHeader, FramePayload) -> t IO StreamId
forall {m :: * -> *} {a}.
MonadBase IO m =>
Chan (a, FramePayload) -> m StreamId
waitSomeCredit Chan (FrameHeader, FramePayload)
frames)
                StreamId -> t IO ()
forall {m :: * -> *}. MonadBase IO m => StreamId -> m ()
receive ((() -> StreamId)
-> (StreamId -> StreamId) -> Either () StreamId -> StreamId
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (StreamId -> () -> StreamId
forall a b. a -> b -> a
const StreamId
0) StreamId -> StreamId
forall a. a -> a
id Either () StreamId
amount)
                StreamId -> t IO StreamId
withdraw StreamId
n
    OutgoingFlowControl -> IO OutgoingFlowControl
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OutgoingFlowControl -> IO OutgoingFlowControl)
-> OutgoingFlowControl -> IO OutgoingFlowControl
forall a b. (a -> b) -> a -> b
$ (StreamId -> IO ())
-> (StreamId -> ClientIO StreamId) -> OutgoingFlowControl
OutgoingFlowControl StreamId -> IO ()
forall {m :: * -> *}. MonadBase IO m => StreamId -> m ()
receive StreamId -> ClientIO StreamId
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, MonadBaseControl IO (t IO)) =>
StreamId -> t IO StreamId
withdraw
  where
    -- TODO: broadcast settings changes from ConnectionSettings using a better data type
    -- than IORef+busy loop. Currently the busy loop is fine because
    -- SettingsInitialWindowSize is typically set at the first frame and hence
    -- waiting one second for an update that is likely to never come is
    -- probably not an issue. There still is an opportunity risk, however, that
    -- an hasted client asks for X > initialWindowSize before the server has
    -- sent its initial SETTINGS frame.
    waitSettingsChange :: StreamId -> m ()
waitSettingsChange StreamId
prev = do
            StreamId
new <- Settings -> StreamId
initialWindowSize (Settings -> StreamId)
-> (ConnectionSettings -> Settings)
-> ConnectionSettings
-> StreamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionSettings -> Settings
_serverSettings (ConnectionSettings -> StreamId)
-> m ConnectionSettings -> m StreamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DispatchControl -> m ConnectionSettings
forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings DispatchControl
control
            if StreamId
new StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
== StreamId
prev then StreamId -> m ()
forall {m :: * -> *}. MonadBase IO m => StreamId -> m ()
threadDelay StreamId
1000000 m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StreamId -> m ()
waitSettingsChange StreamId
prev else () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    waitSomeCredit :: Chan (a, FramePayload) -> m StreamId
waitSomeCredit Chan (a, FramePayload)
frames = do
        (a, FramePayload)
got <- Chan (a, FramePayload) -> m (a, FramePayload)
forall (m :: * -> *) a. MonadBase IO m => Chan a -> m a
readChan Chan (a, FramePayload)
frames
        case (a, FramePayload)
got of
            (a
_, WindowUpdateFrame StreamId
amt) ->
                StreamId -> m StreamId
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamId
amt
            (a, FramePayload)
_                         ->
                [Char] -> m StreamId
forall a. HasCallStack => [Char] -> a
error [Char]
"got forwarded an unknown frame"

sendHeaders
  :: Http2FrameClientStream
  -> HpackEncoderContext
  -> HeaderList
  -> PayloadSplitter
  -> (FrameFlags -> FrameFlags)
  -> ClientIO StreamThread
sendHeaders :: Http2FrameClientStream
-> HpackEncoderContext
-> HeaderList
-> PayloadSplitter
-> (FrameFlags -> FrameFlags)
-> ClientIO StreamThread
sendHeaders Http2FrameClientStream
s HpackEncoderContext
enc HeaderList
hdrs PayloadSplitter
blockSplitter FrameFlags -> FrameFlags
flagmod = do
    Http2FrameClientStream
-> ClientIO [(FrameFlags -> FrameFlags, FramePayload)]
-> ClientIO ()
_sendFrames Http2FrameClientStream
s (IO [(FrameFlags -> FrameFlags, FramePayload)]
-> ClientIO [(FrameFlags -> FrameFlags, FramePayload)]
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 [(FrameFlags -> FrameFlags, FramePayload)]
mkFrames)
    StreamThread -> ClientIO StreamThread
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StreamThread
CST
  where
    mkFrames :: IO [(FrameFlags -> FrameFlags, FramePayload)]
mkFrames = do
        [ByteString]
headerBlockFragments <- PayloadSplitter
blockSplitter PayloadSplitter -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HpackEncoderContext -> HeaderList -> IO ByteString
_encodeHeaders HpackEncoderContext
enc HeaderList
hdrs
        let framers :: [ByteString -> FramePayload]
framers           = (Maybe Priority -> ByteString -> FramePayload
HeadersFrame Maybe Priority
forall a. Maybe a
Nothing) (ByteString -> FramePayload)
-> [ByteString -> FramePayload] -> [ByteString -> FramePayload]
forall a. a -> [a] -> [a]
: (ByteString -> FramePayload) -> [ByteString -> FramePayload]
forall a. a -> [a]
repeat ByteString -> FramePayload
ContinuationFrame
        let frames :: [FramePayload]
frames            = ((ByteString -> FramePayload) -> ByteString -> FramePayload)
-> [ByteString -> FramePayload] -> [ByteString] -> [FramePayload]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ByteString -> FramePayload) -> ByteString -> FramePayload
forall a b. (a -> b) -> a -> b
($) [ByteString -> FramePayload]
framers [ByteString]
headerBlockFragments
        let modifiersReversed :: [FrameFlags -> FrameFlags]
modifiersReversed = (FrameFlags -> FrameFlags
HTTP2.setEndHeader (FrameFlags -> FrameFlags)
-> (FrameFlags -> FrameFlags) -> FrameFlags -> FrameFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameFlags -> FrameFlags
flagmod) (FrameFlags -> FrameFlags)
-> [FrameFlags -> FrameFlags] -> [FrameFlags -> FrameFlags]
forall a. a -> [a] -> [a]
: (FrameFlags -> FrameFlags) -> [FrameFlags -> FrameFlags]
forall a. a -> [a]
repeat FrameFlags -> FrameFlags
forall a. a -> a
id
        let arrangedFrames :: [(FrameFlags -> FrameFlags, FramePayload)]
arrangedFrames    = [(FrameFlags -> FrameFlags, FramePayload)]
-> [(FrameFlags -> FrameFlags, FramePayload)]
forall a. [a] -> [a]
reverse ([(FrameFlags -> FrameFlags, FramePayload)]
 -> [(FrameFlags -> FrameFlags, FramePayload)])
-> [(FrameFlags -> FrameFlags, FramePayload)]
-> [(FrameFlags -> FrameFlags, FramePayload)]
forall a b. (a -> b) -> a -> b
$ [FrameFlags -> FrameFlags]
-> [FramePayload] -> [(FrameFlags -> FrameFlags, FramePayload)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FrameFlags -> FrameFlags]
modifiersReversed ([FramePayload] -> [FramePayload]
forall a. [a] -> [a]
reverse [FramePayload]
frames)
        [(FrameFlags -> FrameFlags, FramePayload)]
-> IO [(FrameFlags -> FrameFlags, FramePayload)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(FrameFlags -> FrameFlags, FramePayload)]
arrangedFrames

-- | A function able to split a header block into multiple fragments.
type PayloadSplitter = ByteString -> [ByteString]

-- | Split headers like so that no payload exceeds server's maxFrameSize.
settingsPayloadSplitter :: ConnectionSettings -> PayloadSplitter
settingsPayloadSplitter :: ConnectionSettings -> PayloadSplitter
settingsPayloadSplitter (ConnectionSettings Settings
_ Settings
srv) =
    StreamId -> PayloadSplitter
fixedSizeChunks (Settings -> StreamId
maxFrameSize Settings
srv)

-- | Breaks a ByteString into fixed-sized chunks.
--
-- @ fixedSizeChunks 2 "hello" = ["he", "ll", "o"] @
fixedSizeChunks :: Int -> ByteString -> [ByteString]
fixedSizeChunks :: StreamId -> PayloadSplitter
fixedSizeChunks StreamId
0   ByteString
_    = [Char] -> [ByteString]
forall a. HasCallStack => [Char] -> a
error [Char]
"cannot chunk by zero-length blocks"
fixedSizeChunks StreamId
_   ByteString
""   = []
fixedSizeChunks StreamId
len ByteString
bstr =
      let
        (ByteString
chunk, ByteString
rest) = StreamId -> ByteString -> (ByteString, ByteString)
ByteString.splitAt StreamId
len ByteString
bstr
      in
        ByteString
chunk ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: StreamId -> PayloadSplitter
fixedSizeChunks StreamId
len ByteString
rest

-- | Sends data, chunked according to the server's preferred chunk size.
--
-- This function does not respect HTTP2 flow-control and send chunks
-- sequentially. Hence, you should first ensure that you have enough
-- flow-control credit (with '_withdrawCredit') or risk a connection failure.
-- When you call _withdrawCredit keep in mind that HTTP2 has flow control at
-- the stream and at the connection level. If you use `http2-client` in a
-- multithreaded conext, you should avoid starving the connection-level
-- flow-control.
--
-- If you want to send bytestrings that fit in RAM, you can use
-- 'Network.HTTP2.Client.Helpers.upload' as a function that implements
-- flow-control.
--
-- This function does not send frames back-to-back, that is, other frames may
-- get interleaved between two chunks (for instance, to give priority to other
-- streams, although no priority queue exists in `http2-client` so far).
--
-- Please refer to '_sendDataChunk' and '_withdrawCredit' as well.
sendData :: Http2Client -> Http2Stream -> FlagSetter -> ByteString -> ClientIO ()
sendData :: Http2Client
-> Http2Stream
-> (FrameFlags -> FrameFlags)
-> ByteString
-> ClientIO ()
sendData Http2Client
conn Http2Stream
stream FrameFlags -> FrameFlags
flagmod ByteString
dat = do
    PayloadSplitter
splitter <- IO PayloadSplitter -> ExceptT ClientError IO PayloadSplitter
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 PayloadSplitter -> ExceptT ClientError IO PayloadSplitter)
-> IO PayloadSplitter -> ExceptT ClientError IO PayloadSplitter
forall a b. (a -> b) -> a -> b
$ Http2Client -> IO PayloadSplitter
_payloadSplitter Http2Client
conn
    let chunks :: [ByteString]
chunks = PayloadSplitter
splitter ByteString
dat
    let pairs :: [(FrameFlags -> FrameFlags, ByteString)]
pairs  = [(FrameFlags -> FrameFlags, ByteString)]
-> [(FrameFlags -> FrameFlags, ByteString)]
forall a. [a] -> [a]
reverse ([(FrameFlags -> FrameFlags, ByteString)]
 -> [(FrameFlags -> FrameFlags, ByteString)])
-> [(FrameFlags -> FrameFlags, ByteString)]
-> [(FrameFlags -> FrameFlags, ByteString)]
forall a b. (a -> b) -> a -> b
$ [FrameFlags -> FrameFlags]
-> [ByteString] -> [(FrameFlags -> FrameFlags, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip (FrameFlags -> FrameFlags
flagmod (FrameFlags -> FrameFlags)
-> [FrameFlags -> FrameFlags] -> [FrameFlags -> FrameFlags]
forall a. a -> [a] -> [a]
: (FrameFlags -> FrameFlags) -> [FrameFlags -> FrameFlags]
forall a. a -> [a]
repeat FrameFlags -> FrameFlags
forall a. a -> a
id) ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
chunks)
    Bool -> ClientIO () -> ClientIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
chunks) (ClientIO () -> ClientIO ()) -> ClientIO () -> ClientIO ()
forall a b. (a -> b) -> a -> b
$ Http2Stream
-> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
_sendDataChunk Http2Stream
stream FrameFlags -> FrameFlags
flagmod ByteString
""
    [(FrameFlags -> FrameFlags, ByteString)]
-> ((FrameFlags -> FrameFlags, ByteString) -> ClientIO ())
-> ClientIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(FrameFlags -> FrameFlags, ByteString)]
pairs (((FrameFlags -> FrameFlags, ByteString) -> ClientIO ())
 -> ClientIO ())
-> ((FrameFlags -> FrameFlags, ByteString) -> ClientIO ())
-> ClientIO ()
forall a b. (a -> b) -> a -> b
$ \(FrameFlags -> FrameFlags
flags, ByteString
chunk) -> Http2Stream
-> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
_sendDataChunk Http2Stream
stream FrameFlags -> FrameFlags
flags ByteString
chunk

sendDataFrame
  :: Http2FrameClientStream
  -> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
sendDataFrame :: Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
sendDataFrame Http2FrameClientStream
s FrameFlags -> FrameFlags
flagmod ByteString
dat = do
    Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> FramePayload -> ClientIO ()
sendOne Http2FrameClientStream
s FrameFlags -> FrameFlags
flagmod (ByteString -> FramePayload
DataFrame ByteString
dat)

sendResetFrame :: Http2FrameClientStream -> ErrorCode -> ClientIO ()
sendResetFrame :: Http2FrameClientStream -> ErrorCode -> ClientIO ()
sendResetFrame Http2FrameClientStream
s ErrorCode
err = do
    Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> FramePayload -> ClientIO ()
sendOne Http2FrameClientStream
s FrameFlags -> FrameFlags
forall a. a -> a
id (ErrorCode -> FramePayload
RSTStreamFrame ErrorCode
err)

sendGTFOFrame
  :: Http2FrameClientStream
     -> StreamId -> ErrorCode -> ByteString -> ClientIO ()
sendGTFOFrame :: Http2FrameClientStream
-> StreamId -> ErrorCode -> ByteString -> ClientIO ()
sendGTFOFrame Http2FrameClientStream
s StreamId
lastStreamId ErrorCode
err ByteString
errStr = do
    Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> FramePayload -> ClientIO ()
sendOne Http2FrameClientStream
s FrameFlags -> FrameFlags
forall a. a -> a
id (StreamId -> ErrorCode -> ByteString -> FramePayload
GoAwayFrame StreamId
lastStreamId ErrorCode
err ByteString
errStr)

rfcError :: String -> a
rfcError :: forall a. [Char] -> a
rfcError [Char]
msg = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
msg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"draft-ietf-httpbis-http2-17")

sendPingFrame
  :: Http2FrameClientStream
  -> (FrameFlags -> FrameFlags)
  -> ByteString
  -> ClientIO ()
sendPingFrame :: Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> ByteString -> ClientIO ()
sendPingFrame Http2FrameClientStream
s FrameFlags -> FrameFlags
flags ByteString
dat
  | Http2FrameClientStream -> StreamId
_getStreamId Http2FrameClientStream
s StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
/= StreamId
0        =
        [Char] -> ClientIO ()
forall a. [Char] -> a
rfcError [Char]
"PING frames are not associated with any individual stream."
  | ByteString -> StreamId
ByteString.length ByteString
dat StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
/= StreamId
8 =
        [Char] -> ClientIO ()
forall a. [Char] -> a
rfcError [Char]
"PING frames MUST contain 8 octets"
  | Bool
otherwise                  = Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> FramePayload -> ClientIO ()
sendOne Http2FrameClientStream
s FrameFlags -> FrameFlags
flags (ByteString -> FramePayload
PingFrame ByteString
dat)

sendWindowUpdateFrame
  :: Http2FrameClientStream -> WindowSize -> ClientIO ()
sendWindowUpdateFrame :: Http2FrameClientStream -> StreamId -> ClientIO ()
sendWindowUpdateFrame Http2FrameClientStream
s StreamId
amount = do
    let payload :: FramePayload
payload = StreamId -> FramePayload
WindowUpdateFrame StreamId
amount
    Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> FramePayload -> ClientIO ()
sendOne Http2FrameClientStream
s FrameFlags -> FrameFlags
forall a. a -> a
id FramePayload
payload
    () -> ClientIO ()
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

sendSettingsFrame
  :: Http2FrameClientStream
     -> (FrameFlags -> FrameFlags) -> SettingsList -> ClientIO ()
sendSettingsFrame :: Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> SettingsList -> ClientIO ()
sendSettingsFrame Http2FrameClientStream
s FrameFlags -> FrameFlags
flags SettingsList
setts
  | Http2FrameClientStream -> StreamId
_getStreamId Http2FrameClientStream
s StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
/= StreamId
0        =
        [Char] -> ClientIO ()
forall a. [Char] -> a
rfcError [Char]
"The stream identifier for a SETTINGS frame MUST be zero (0x0)."
  | Bool
otherwise                  = do
    let payload :: FramePayload
payload = SettingsList -> FramePayload
SettingsFrame SettingsList
setts
    Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> FramePayload -> ClientIO ()
sendOne Http2FrameClientStream
s FrameFlags -> FrameFlags
flags FramePayload
payload
    () -> ClientIO ()
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

sendPriorityFrame :: Http2FrameClientStream -> Priority -> ClientIO ()
sendPriorityFrame :: Http2FrameClientStream -> Priority -> ClientIO ()
sendPriorityFrame Http2FrameClientStream
s Priority
p = do
    let payload :: FramePayload
payload = Priority -> FramePayload
PriorityFrame Priority
p
    Http2FrameClientStream
-> (FrameFlags -> FrameFlags) -> FramePayload -> ClientIO ()
sendOne Http2FrameClientStream
s FrameFlags -> FrameFlags
forall a. a -> a
id FramePayload
payload
    () -> ClientIO ()
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Runs an action, rethrowing exception 50ms later.
--
-- In a context where asynchronous are likely to occur this function gives a
-- chance to other threads to do some work before Async linking reaps them all.
--
-- In particular, servers are likely to close their TCP connection soon after
-- sending a GoAwayFrame and we want to give a better chance to clients to
-- observe the GoAwayFrame in their handlers to distinguish GoAwayFrames
-- followed by TCP disconnection and plain TCP resets. As a result, this
-- function is mostly used to delay 'dispatchFrames'. A more involved
-- and future design will be to inline the various loop-processes for
-- dispatchFrames and GoAwayHandlers in a same thread (e.g., using
-- pipe/conduit to retain composability).
delayException :: ClientIO a -> ClientIO a
delayException :: forall a. ClientIO a -> ClientIO a
delayException ClientIO a
act = ClientIO a
act ClientIO a -> (SomeException -> ClientIO a) -> ClientIO a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> ClientIO a
forall a. SomeException -> ClientIO a
slowdown
  where
    slowdown :: SomeException -> ClientIO a
    slowdown :: forall a. SomeException -> ClientIO a
slowdown SomeException
e = StreamId -> ClientIO ()
forall {m :: * -> *}. MonadBase IO m => StreamId -> m ()
threadDelay StreamId
50000 ClientIO () -> ExceptT ClientError IO a -> ExceptT ClientError IO a
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
>> SomeException -> ExceptT ClientError IO a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO SomeException
e