{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
module Network.HTTP2.Client.Dispatch where

import           Control.Exception (throwIO)
import           Control.Monad.Base (MonadBase, liftBase)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as ByteString
import           Foreign.Marshal.Alloc (mallocBytes, finalizerFree)
import           Foreign.ForeignPtr (newForeignPtr)
import           Data.IORef.Lifted (IORef, atomicModifyIORef', newIORef, readIORef)
import           Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import           GHC.Exception (Exception)
import           Network.HPACK as HPACK
import qualified Network.HPACK.Token as HPACK
import           Network.HTTP2.Frame as HTTP2

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

type DispatchChan = FramesChan FrameDecodeError

-- | A fallback handler for frames.
type FallBackFrameHandler = (FrameHeader, FramePayload) -> ClientIO ()

-- | Default FallBackFrameHandler that ignores frames.
ignoreFallbackHandler :: FallBackFrameHandler
ignoreFallbackHandler :: FallBackFrameHandler
ignoreFallbackHandler = ClientIO () -> FallBackFrameHandler
forall a b. a -> b -> a
const (ClientIO () -> FallBackFrameHandler)
-> ClientIO () -> FallBackFrameHandler
forall a b. (a -> b) -> a -> b
$ () -> ClientIO ()
forall a. a -> ExceptT ClientError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | An exception thrown when the server sends a GoAwayFrame.
data RemoteSentGoAwayFrame = RemoteSentGoAwayFrame !StreamId !ErrorCode !ByteString
  deriving Int -> RemoteSentGoAwayFrame -> ShowS
[RemoteSentGoAwayFrame] -> ShowS
RemoteSentGoAwayFrame -> String
(Int -> RemoteSentGoAwayFrame -> ShowS)
-> (RemoteSentGoAwayFrame -> String)
-> ([RemoteSentGoAwayFrame] -> ShowS)
-> Show RemoteSentGoAwayFrame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RemoteSentGoAwayFrame -> ShowS
showsPrec :: Int -> RemoteSentGoAwayFrame -> ShowS
$cshow :: RemoteSentGoAwayFrame -> String
show :: RemoteSentGoAwayFrame -> String
$cshowList :: [RemoteSentGoAwayFrame] -> ShowS
showList :: [RemoteSentGoAwayFrame] -> ShowS
Show
instance Exception RemoteSentGoAwayFrame

-- | A Handler for exceptional circumstances.
type GoAwayHandler = RemoteSentGoAwayFrame -> ClientIO ()

-- | Default GoAwayHandler throws a 'RemoteSentGoAwayFrame' in the current
-- thread.
--
-- A probably sharper handler if you want to abruptly stop any operation is to
-- get the 'ThreadId' of the main client thread and using
-- 'Control.Exception.Base.throwTo'.
--
-- There's an inherent race condition when receiving a GoAway frame because the
-- server will likely close the connection which will lead to TCP errors as
-- well.
defaultGoAwayHandler :: GoAwayHandler
defaultGoAwayHandler :: GoAwayHandler
defaultGoAwayHandler = 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 ())
-> (RemoteSentGoAwayFrame -> IO ()) -> GoAwayHandler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteSentGoAwayFrame -> IO ()
forall e a. Exception e => e -> IO a
throwIO

data StreamFSMState =
    Idle
  | ReservedRemote
  | Open
  | HalfClosedRemote
  | HalfClosedLocal
  | Closed

data StreamEvent =
    StreamHeadersEvent !FrameHeader !HeaderList
  | StreamPushPromiseEvent !FrameHeader !StreamId !HeaderList
  | StreamDataEvent !FrameHeader ByteString
  | StreamErrorEvent !FrameHeader ErrorCode
  deriving Int -> StreamEvent -> ShowS
[StreamEvent] -> ShowS
StreamEvent -> String
(Int -> StreamEvent -> ShowS)
-> (StreamEvent -> String)
-> ([StreamEvent] -> ShowS)
-> Show StreamEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StreamEvent -> ShowS
showsPrec :: Int -> StreamEvent -> ShowS
$cshow :: StreamEvent -> String
show :: StreamEvent -> String
$cshowList :: [StreamEvent] -> ShowS
showList :: [StreamEvent] -> ShowS
Show

data StreamState = StreamState {
    StreamState -> Chan (FrameHeader, FramePayload)
_streamStateWindowUpdatesChan :: !(Chan (FrameHeader, FramePayload))
  , StreamState -> Chan StreamEvent
_streamStateEvents            :: !(Chan StreamEvent)
  , StreamState -> StreamFSMState
_streamStateFSMState          :: !StreamFSMState
  }

data Dispatch = Dispatch {
    Dispatch -> IORef Int
_dispatchMaxStreamId    :: !(IORef StreamId)
  , Dispatch -> IORef (IntMap StreamState)
_dispatchCurrentStreams :: !(IORef (IntMap StreamState))
  }

newDispatchIO :: MonadBase IO m => m Dispatch
newDispatchIO :: forall (m :: * -> *). MonadBase IO m => m Dispatch
newDispatchIO = IORef Int -> IORef (IntMap StreamState) -> Dispatch
Dispatch (IORef Int -> IORef (IntMap StreamState) -> Dispatch)
-> m (IORef Int) -> m (IORef (IntMap StreamState) -> Dispatch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (IORef Int)
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef Int
0 m (IORef (IntMap StreamState) -> Dispatch)
-> m (IORef (IntMap StreamState)) -> m Dispatch
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IntMap StreamState -> m (IORef (IntMap StreamState))
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef (IntMap StreamState
forall a. IntMap a
IntMap.empty)

readMaxReceivedStreamIdIO :: MonadBase IO m => Dispatch -> m StreamId
readMaxReceivedStreamIdIO :: forall (m :: * -> *). MonadBase IO m => Dispatch -> m Int
readMaxReceivedStreamIdIO = IORef Int -> m Int
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef (IORef Int -> m Int)
-> (Dispatch -> IORef Int) -> Dispatch -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dispatch -> IORef Int
_dispatchMaxStreamId

registerStream :: MonadBase IO m => Dispatch -> StreamId -> StreamState -> m ()
registerStream :: forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> Int -> StreamState -> m ()
registerStream Dispatch
d Int
sid StreamState
st =
    IORef (IntMap StreamState)
-> (IntMap StreamState -> (IntMap StreamState, ())) -> m ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (Dispatch -> IORef (IntMap StreamState)
_dispatchCurrentStreams Dispatch
d) ((IntMap StreamState -> (IntMap StreamState, ())) -> m ())
-> (IntMap StreamState -> (IntMap StreamState, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \IntMap StreamState
xs ->
      let v :: IntMap StreamState
v = (Int -> StreamState -> IntMap StreamState -> IntMap StreamState
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
sid StreamState
st IntMap StreamState
xs) in (IntMap StreamState
v, ())

lookupStreamState :: MonadBase IO m => Dispatch -> StreamId -> m (Maybe StreamState)
lookupStreamState :: forall (m :: * -> *).
MonadBase IO m =>
Dispatch -> Int -> m (Maybe StreamState)
lookupStreamState Dispatch
d Int
sid =
    Int -> IntMap StreamState -> Maybe StreamState
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
sid (IntMap StreamState -> Maybe StreamState)
-> m (IntMap StreamState) -> m (Maybe StreamState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap StreamState) -> m (IntMap StreamState)
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef (Dispatch -> IORef (IntMap StreamState)
_dispatchCurrentStreams Dispatch
d)

closeLocalStream :: MonadBase IO m => Dispatch -> StreamId -> m ()
closeLocalStream :: forall (m :: * -> *). MonadBase IO m => Dispatch -> Int -> m ()
closeLocalStream Dispatch
d Int
sid =
    IORef (IntMap StreamState)
-> (IntMap StreamState -> (IntMap StreamState, ())) -> m ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (Dispatch -> IORef (IntMap StreamState)
_dispatchCurrentStreams Dispatch
d) ((IntMap StreamState -> (IntMap StreamState, ())) -> m ())
-> (IntMap StreamState -> (IntMap StreamState, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \IntMap StreamState
xs ->
      let (Maybe StreamState
_,IntMap StreamState
v) = (Int -> StreamState -> Maybe StreamState)
-> Int
-> IntMap StreamState
-> (Maybe StreamState, IntMap StreamState)
forall a.
(Int -> a -> Maybe a) -> Int -> IntMap a -> (Maybe a, IntMap a)
IntMap.updateLookupWithKey Int -> StreamState -> Maybe StreamState
f Int
sid IntMap StreamState
xs in (IntMap StreamState
v, ())
  where
    f :: StreamId -> StreamState -> Maybe StreamState
    f :: Int -> StreamState -> Maybe StreamState
f Int
_ StreamState
st = case StreamState -> StreamFSMState
_streamStateFSMState StreamState
st of
        StreamFSMState
HalfClosedRemote -> Maybe StreamState
forall a. Maybe a
Nothing
        StreamFSMState
Closed           -> Maybe StreamState
forall a. Maybe a
Nothing
        StreamFSMState
_ -> StreamState -> Maybe StreamState
forall a. a -> Maybe a
Just (StreamState -> Maybe StreamState)
-> StreamState -> Maybe StreamState
forall a b. (a -> b) -> a -> b
$ StreamState
st { _streamStateFSMState = HalfClosedLocal }

closeRemoteStream :: MonadBase IO m => Dispatch -> StreamId -> m ()
closeRemoteStream :: forall (m :: * -> *). MonadBase IO m => Dispatch -> Int -> m ()
closeRemoteStream Dispatch
d Int
sid =
    IORef (IntMap StreamState)
-> (IntMap StreamState -> (IntMap StreamState, ())) -> m ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (Dispatch -> IORef (IntMap StreamState)
_dispatchCurrentStreams Dispatch
d) ((IntMap StreamState -> (IntMap StreamState, ())) -> m ())
-> (IntMap StreamState -> (IntMap StreamState, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \IntMap StreamState
xs ->
      let (Maybe StreamState
_,IntMap StreamState
v) = (Int -> StreamState -> Maybe StreamState)
-> Int
-> IntMap StreamState
-> (Maybe StreamState, IntMap StreamState)
forall a.
(Int -> a -> Maybe a) -> Int -> IntMap a -> (Maybe a, IntMap a)
IntMap.updateLookupWithKey Int -> StreamState -> Maybe StreamState
f Int
sid IntMap StreamState
xs in (IntMap StreamState
v, ())
  where
    f :: StreamId -> StreamState -> Maybe StreamState
    f :: Int -> StreamState -> Maybe StreamState
f Int
_ StreamState
st = case StreamState -> StreamFSMState
_streamStateFSMState StreamState
st of
        StreamFSMState
HalfClosedLocal  -> Maybe StreamState
forall a. Maybe a
Nothing
        StreamFSMState
Closed           -> Maybe StreamState
forall a. Maybe a
Nothing
        StreamFSMState
_ -> StreamState -> Maybe StreamState
forall a. a -> Maybe a
Just (StreamState -> Maybe StreamState)
-> StreamState -> Maybe StreamState
forall a b. (a -> b) -> a -> b
$ StreamState
st { _streamStateFSMState = HalfClosedRemote }

closeReleaseStream :: MonadBase IO m => Dispatch -> StreamId -> m ()
closeReleaseStream :: forall (m :: * -> *). MonadBase IO m => Dispatch -> Int -> m ()
closeReleaseStream Dispatch
d Int
sid =
    IORef (IntMap StreamState)
-> (IntMap StreamState -> (IntMap StreamState, ())) -> m ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (Dispatch -> IORef (IntMap StreamState)
_dispatchCurrentStreams Dispatch
d) ((IntMap StreamState -> (IntMap StreamState, ())) -> m ())
-> (IntMap StreamState -> (IntMap StreamState, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \IntMap StreamState
xs ->
      let v :: IntMap StreamState
v = (Int -> IntMap StreamState -> IntMap StreamState
forall a. Int -> IntMap a -> IntMap a
IntMap.delete Int
sid IntMap StreamState
xs) in (IntMap StreamState
v, ())

-- | Couples client and server settings together.
data ConnectionSettings = ConnectionSettings {
    ConnectionSettings -> Settings
_clientSettings :: !Settings
  , ConnectionSettings -> Settings
_serverSettings :: !Settings
  }

defaultConnectionSettings :: ConnectionSettings
defaultConnectionSettings :: ConnectionSettings
defaultConnectionSettings =
    Settings -> Settings -> ConnectionSettings
ConnectionSettings Settings
defaultSettings Settings
defaultSettings

data PingHandler = PingHandler !(Chan (FrameHeader, FramePayload))

newPingHandler :: MonadBase IO m => m PingHandler
newPingHandler :: forall (m :: * -> *). MonadBase IO m => m PingHandler
newPingHandler = Chan (FrameHeader, FramePayload) -> PingHandler
PingHandler (Chan (FrameHeader, FramePayload) -> PingHandler)
-> m (Chan (FrameHeader, FramePayload)) -> m PingHandler
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Chan (FrameHeader, FramePayload))
forall (m :: * -> *) a. MonadBase IO m => m (Chan a)
newChan

notifyPingHandler :: MonadBase IO m => (FrameHeader, FramePayload) -> PingHandler -> m ()
notifyPingHandler :: forall (m :: * -> *).
MonadBase IO m =>
(FrameHeader, FramePayload) -> PingHandler -> m ()
notifyPingHandler (FrameHeader, FramePayload)
dat (PingHandler Chan (FrameHeader, FramePayload)
c) = Chan (FrameHeader, FramePayload)
-> (FrameHeader, FramePayload) -> m ()
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan Chan (FrameHeader, FramePayload)
c (FrameHeader, FramePayload)
dat

waitPingReply :: MonadBase IO m => PingHandler -> m (FrameHeader, FramePayload)
waitPingReply :: forall (m :: * -> *).
MonadBase IO m =>
PingHandler -> m (FrameHeader, FramePayload)
waitPingReply (PingHandler Chan (FrameHeader, FramePayload)
c) = Chan (FrameHeader, FramePayload) -> m (FrameHeader, FramePayload)
forall (m :: * -> *) a. MonadBase IO m => Chan a -> m a
readChan Chan (FrameHeader, FramePayload)
c

data SetSettingsHandler = SetSettingsHandler !(Chan (FrameHeader, FramePayload))

newSetSettingsHandler :: MonadBase IO m => m SetSettingsHandler
newSetSettingsHandler :: forall (m :: * -> *). MonadBase IO m => m SetSettingsHandler
newSetSettingsHandler = Chan (FrameHeader, FramePayload) -> SetSettingsHandler
SetSettingsHandler (Chan (FrameHeader, FramePayload) -> SetSettingsHandler)
-> m (Chan (FrameHeader, FramePayload)) -> m SetSettingsHandler
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Chan (FrameHeader, FramePayload))
forall (m :: * -> *) a. MonadBase IO m => m (Chan a)
newChan

notifySetSettingsHandler :: MonadBase IO m => (FrameHeader, FramePayload) -> SetSettingsHandler -> m ()
notifySetSettingsHandler :: forall (m :: * -> *).
MonadBase IO m =>
(FrameHeader, FramePayload) -> SetSettingsHandler -> m ()
notifySetSettingsHandler (FrameHeader, FramePayload)
dat (SetSettingsHandler Chan (FrameHeader, FramePayload)
c) = Chan (FrameHeader, FramePayload)
-> (FrameHeader, FramePayload) -> m ()
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan Chan (FrameHeader, FramePayload)
c (FrameHeader, FramePayload)
dat

waitSetSettingsReply :: MonadBase IO m => SetSettingsHandler -> m (FrameHeader, FramePayload)
waitSetSettingsReply :: forall (m :: * -> *).
MonadBase IO m =>
SetSettingsHandler -> m (FrameHeader, FramePayload)
waitSetSettingsReply (SetSettingsHandler Chan (FrameHeader, FramePayload)
c) = Chan (FrameHeader, FramePayload) -> m (FrameHeader, FramePayload)
forall (m :: * -> *) a. MonadBase IO m => Chan a -> m a
readChan Chan (FrameHeader, FramePayload)
c

registerPingHandler :: DispatchControl -> ByteString -> IO PingHandler
registerPingHandler :: DispatchControl -> ByteString -> IO PingHandler
registerPingHandler DispatchControl
dc ByteString
dat = do
    PingHandler
handler <- IO PingHandler
forall (m :: * -> *). MonadBase IO m => m PingHandler
newPingHandler
    IORef [(ByteString, PingHandler)]
-> ([(ByteString, PingHandler)]
    -> ([(ByteString, PingHandler)], ()))
-> IO ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (DispatchControl -> IORef [(ByteString, PingHandler)]
_dispatchControlPingHandlers DispatchControl
dc) (\[(ByteString, PingHandler)]
xs ->
        ((ByteString
dat,PingHandler
handler)(ByteString, PingHandler)
-> [(ByteString, PingHandler)] -> [(ByteString, PingHandler)]
forall a. a -> [a] -> [a]
:[(ByteString, PingHandler)]
xs, ()))
    PingHandler -> IO PingHandler
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PingHandler
handler

lookupAndReleasePingHandler :: MonadBase IO m => DispatchControl -> ByteString -> m (Maybe PingHandler)
lookupAndReleasePingHandler :: forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> ByteString -> m (Maybe PingHandler)
lookupAndReleasePingHandler DispatchControl
dc ByteString
dat =
    IORef [(ByteString, PingHandler)]
-> ([(ByteString, PingHandler)]
    -> ([(ByteString, PingHandler)], Maybe PingHandler))
-> m (Maybe PingHandler)
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (DispatchControl -> IORef [(ByteString, PingHandler)]
_dispatchControlPingHandlers DispatchControl
dc) [(ByteString, PingHandler)]
-> ([(ByteString, PingHandler)], Maybe PingHandler)
forall {b}. [(ByteString, b)] -> ([(ByteString, b)], Maybe b)
f
  where
    -- Note: we considered doing a single pass for this folds but we expect the
    -- size of handlers to be small anyway (hence, we use a List for
    -- storing the handlers).
    f :: [(ByteString, b)] -> ([(ByteString, b)], Maybe b)
f [(ByteString, b)]
xs = (((ByteString, b) -> Bool) -> [(ByteString, b)] -> [(ByteString, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ByteString, b)
x -> ByteString
dat ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= (ByteString, b) -> ByteString
forall a b. (a, b) -> a
fst (ByteString, b)
x) [(ByteString, b)]
xs, ByteString -> [(ByteString, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
dat [(ByteString, b)]
xs)

registerSetSettingsHandler :: MonadBase IO m => DispatchControl -> m SetSettingsHandler
registerSetSettingsHandler :: forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m SetSettingsHandler
registerSetSettingsHandler DispatchControl
dc = do
    SetSettingsHandler
handler <- m SetSettingsHandler
forall (m :: * -> *). MonadBase IO m => m SetSettingsHandler
newSetSettingsHandler
    IORef [SetSettingsHandler]
-> ([SetSettingsHandler] -> ([SetSettingsHandler], ())) -> m ()
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (DispatchControl -> IORef [SetSettingsHandler]
_dispatchControlSetSettingsHandlers DispatchControl
dc) (\[SetSettingsHandler]
xs ->
        (SetSettingsHandler
handlerSetSettingsHandler -> [SetSettingsHandler] -> [SetSettingsHandler]
forall a. a -> [a] -> [a]
:[SetSettingsHandler]
xs, ()))
    SetSettingsHandler -> m SetSettingsHandler
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SetSettingsHandler
handler

lookupAndReleaseSetSettingsHandler :: MonadBase IO m => DispatchControl -> m (Maybe SetSettingsHandler)
lookupAndReleaseSetSettingsHandler :: forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m (Maybe SetSettingsHandler)
lookupAndReleaseSetSettingsHandler DispatchControl
dc =
    IORef [SetSettingsHandler]
-> ([SetSettingsHandler]
    -> ([SetSettingsHandler], Maybe SetSettingsHandler))
-> m (Maybe SetSettingsHandler)
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (DispatchControl -> IORef [SetSettingsHandler]
_dispatchControlSetSettingsHandlers DispatchControl
dc) [SetSettingsHandler]
-> ([SetSettingsHandler], Maybe SetSettingsHandler)
forall {a}. [a] -> ([a], Maybe a)
f
  where
    f :: [a] -> ([a], Maybe a)
f []     = ([], Maybe a
forall a. Maybe a
Nothing)
    f (a
x:[a]
xs) = ([a]
xs, a -> Maybe a
forall a. a -> Maybe a
Just a
x)

data DispatchControl = DispatchControl {
    DispatchControl -> IORef ConnectionSettings
_dispatchControlConnectionSettings  :: !(IORef ConnectionSettings)
  , DispatchControl -> HpackEncoderContext
_dispatchControlHpackEncoder        :: !HpackEncoderContext
  , DispatchControl -> ByteString -> ClientIO ()
_dispatchControlAckPing             :: !(ByteString -> ClientIO ())
  , DispatchControl -> ClientIO ()
_dispatchControlAckSettings         :: !(ClientIO ())
  , DispatchControl -> GoAwayHandler
_dispatchControlOnGoAway            :: !GoAwayHandler
  , DispatchControl -> FallBackFrameHandler
_dispatchControlOnFallback          :: !FallBackFrameHandler
  , DispatchControl -> IORef [(ByteString, PingHandler)]
_dispatchControlPingHandlers        :: !(IORef [(ByteString, PingHandler)])
  , DispatchControl -> IORef [SetSettingsHandler]
_dispatchControlSetSettingsHandlers :: !(IORef [SetSettingsHandler])
  }

newDispatchControlIO
  :: MonadBase IO m
  => Size
  -> (ByteString -> ClientIO ())
  -> (ClientIO ())
  -> GoAwayHandler
  -> FallBackFrameHandler
  -> m DispatchControl
newDispatchControlIO :: forall (m :: * -> *).
MonadBase IO m =>
Int
-> (ByteString -> ClientIO ())
-> ClientIO ()
-> GoAwayHandler
-> FallBackFrameHandler
-> m DispatchControl
newDispatchControlIO Int
encoderBufSize ByteString -> ClientIO ()
ackPing ClientIO ()
ackSetts GoAwayHandler
onGoAway FallBackFrameHandler
onFallback =
    IORef ConnectionSettings
-> HpackEncoderContext
-> (ByteString -> ClientIO ())
-> ClientIO ()
-> GoAwayHandler
-> FallBackFrameHandler
-> IORef [(ByteString, PingHandler)]
-> IORef [SetSettingsHandler]
-> DispatchControl
DispatchControl (IORef ConnectionSettings
 -> HpackEncoderContext
 -> (ByteString -> ClientIO ())
 -> ClientIO ()
 -> GoAwayHandler
 -> FallBackFrameHandler
 -> IORef [(ByteString, PingHandler)]
 -> IORef [SetSettingsHandler]
 -> DispatchControl)
-> m (IORef ConnectionSettings)
-> m (HpackEncoderContext
      -> (ByteString -> ClientIO ())
      -> ClientIO ()
      -> GoAwayHandler
      -> FallBackFrameHandler
      -> IORef [(ByteString, PingHandler)]
      -> IORef [SetSettingsHandler]
      -> DispatchControl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnectionSettings -> m (IORef ConnectionSettings)
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef ConnectionSettings
defaultConnectionSettings
                    m (HpackEncoderContext
   -> (ByteString -> ClientIO ())
   -> ClientIO ()
   -> GoAwayHandler
   -> FallBackFrameHandler
   -> IORef [(ByteString, PingHandler)]
   -> IORef [SetSettingsHandler]
   -> DispatchControl)
-> m HpackEncoderContext
-> m ((ByteString -> ClientIO ())
      -> ClientIO ()
      -> GoAwayHandler
      -> FallBackFrameHandler
      -> IORef [(ByteString, PingHandler)]
      -> IORef [SetSettingsHandler]
      -> DispatchControl)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> m HpackEncoderContext
forall (m :: * -> *).
MonadBase IO m =>
Int -> m HpackEncoderContext
newHpackEncoderContext Int
encoderBufSize
                    m ((ByteString -> ClientIO ())
   -> ClientIO ()
   -> GoAwayHandler
   -> FallBackFrameHandler
   -> IORef [(ByteString, PingHandler)]
   -> IORef [SetSettingsHandler]
   -> DispatchControl)
-> m (ByteString -> ClientIO ())
-> m (ClientIO ()
      -> GoAwayHandler
      -> FallBackFrameHandler
      -> IORef [(ByteString, PingHandler)]
      -> IORef [SetSettingsHandler]
      -> DispatchControl)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> ClientIO ()) -> m (ByteString -> ClientIO ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> ClientIO ()
ackPing
                    m (ClientIO ()
   -> GoAwayHandler
   -> FallBackFrameHandler
   -> IORef [(ByteString, PingHandler)]
   -> IORef [SetSettingsHandler]
   -> DispatchControl)
-> m (ClientIO ())
-> m (GoAwayHandler
      -> FallBackFrameHandler
      -> IORef [(ByteString, PingHandler)]
      -> IORef [SetSettingsHandler]
      -> DispatchControl)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClientIO () -> m (ClientIO ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientIO ()
ackSetts
                    m (GoAwayHandler
   -> FallBackFrameHandler
   -> IORef [(ByteString, PingHandler)]
   -> IORef [SetSettingsHandler]
   -> DispatchControl)
-> m GoAwayHandler
-> m (FallBackFrameHandler
      -> IORef [(ByteString, PingHandler)]
      -> IORef [SetSettingsHandler]
      -> DispatchControl)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GoAwayHandler -> m GoAwayHandler
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GoAwayHandler
onGoAway
                    m (FallBackFrameHandler
   -> IORef [(ByteString, PingHandler)]
   -> IORef [SetSettingsHandler]
   -> DispatchControl)
-> m FallBackFrameHandler
-> m (IORef [(ByteString, PingHandler)]
      -> IORef [SetSettingsHandler] -> DispatchControl)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FallBackFrameHandler -> m FallBackFrameHandler
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FallBackFrameHandler
onFallback
                    m (IORef [(ByteString, PingHandler)]
   -> IORef [SetSettingsHandler] -> DispatchControl)
-> m (IORef [(ByteString, PingHandler)])
-> m (IORef [SetSettingsHandler] -> DispatchControl)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(ByteString, PingHandler)]
-> m (IORef [(ByteString, PingHandler)])
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef []
                    m (IORef [SetSettingsHandler] -> DispatchControl)
-> m (IORef [SetSettingsHandler]) -> m DispatchControl
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SetSettingsHandler] -> m (IORef [SetSettingsHandler])
forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef []

newHpackEncoderContext :: MonadBase IO m => Size -> m HpackEncoderContext
newHpackEncoderContext :: forall (m :: * -> *).
MonadBase IO m =>
Int -> m HpackEncoderContext
newHpackEncoderContext Int
encoderBufSize = IO HpackEncoderContext -> m HpackEncoderContext
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO HpackEncoderContext -> m HpackEncoderContext)
-> IO HpackEncoderContext -> m HpackEncoderContext
forall a b. (a -> b) -> a -> b
$ do
    let strategy :: EncodeStrategy
strategy = (EncodeStrategy
HPACK.defaultEncodeStrategy { HPACK.useHuffman = True })
    DynamicTable
dt <- Int -> IO DynamicTable
HPACK.newDynamicTableForEncoding Int
HPACK.defaultDynamicTableSize
    Ptr Word8
buf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
encoderBufSize
    ForeignPtr Word8
ptr <- FinalizerPtr Word8 -> Ptr Word8 -> IO (ForeignPtr Word8)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr Word8
forall a. FinalizerPtr a
finalizerFree Ptr Word8
buf
    HpackEncoderContext -> IO HpackEncoderContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HpackEncoderContext -> IO HpackEncoderContext)
-> HpackEncoderContext -> IO HpackEncoderContext
forall a b. (a -> b) -> a -> b
$ (HeaderList -> IO ByteString)
-> (Int -> IO ()) -> HpackEncoderContext
HpackEncoderContext
            (\HeaderList
hdrs -> EncodeStrategy
-> DynamicTable
-> Ptr Word8
-> ForeignPtr Word8
-> HeaderList
-> IO ByteString
encoder EncodeStrategy
strategy DynamicTable
dt Ptr Word8
buf ForeignPtr Word8
ptr HeaderList
hdrs)
            (\Int
n -> Int -> DynamicTable -> IO ()
HPACK.setLimitForEncoding Int
n DynamicTable
dt)
  where
    encoder :: EncodeStrategy
-> DynamicTable
-> Ptr Word8
-> ForeignPtr Word8
-> HeaderList
-> IO ByteString
encoder EncodeStrategy
strategy DynamicTable
dt Ptr Word8
buf ForeignPtr Word8
ptr HeaderList
hdrs = do
        let hdrs' :: [(Token, ByteString)]
hdrs' = ((ByteString, ByteString) -> (Token, ByteString))
-> HeaderList -> [(Token, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ByteString
k,ByteString
v) -> let !t :: Token
t = ByteString -> Token
HPACK.toToken ByteString
k in (Token
t,ByteString
v)) HeaderList
hdrs
        ([(Token, ByteString)], Int)
remainder <- Ptr Word8
-> Int
-> EncodeStrategy
-> Bool
-> DynamicTable
-> [(Token, ByteString)]
-> IO ([(Token, ByteString)], Int)
HPACK.encodeTokenHeader Ptr Word8
buf Int
encoderBufSize EncodeStrategy
strategy Bool
True DynamicTable
dt [(Token, ByteString)]
hdrs'
        case ([(Token, ByteString)], Int)
remainder of
            ([],Int
len) -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> ByteString
ByteString.fromForeignPtr ForeignPtr Word8
ptr Int
0 Int
len
            ([(Token, ByteString)]
_,Int
_)  -> BufferOverrun -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO BufferOverrun
HPACK.BufferOverrun

readSettings :: MonadBase IO m => DispatchControl -> m ConnectionSettings
readSettings :: forall (m :: * -> *).
MonadBase IO m =>
DispatchControl -> m ConnectionSettings
readSettings = IORef ConnectionSettings -> m ConnectionSettings
forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef (IORef ConnectionSettings -> m ConnectionSettings)
-> (DispatchControl -> IORef ConnectionSettings)
-> DispatchControl
-> m ConnectionSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DispatchControl -> IORef ConnectionSettings
_dispatchControlConnectionSettings

modifySettings :: MonadBase IO m => DispatchControl -> (ConnectionSettings -> (ConnectionSettings, a)) -> m a
modifySettings :: forall (m :: * -> *) a.
MonadBase IO m =>
DispatchControl
-> (ConnectionSettings -> (ConnectionSettings, a)) -> m a
modifySettings DispatchControl
d = IORef ConnectionSettings
-> (ConnectionSettings -> (ConnectionSettings, a)) -> m a
forall (m :: * -> *) a b.
MonadBase IO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (DispatchControl -> IORef ConnectionSettings
_dispatchControlConnectionSettings DispatchControl
d)

-- | Helper to carry around the HPACK encoder for outgoing header blocks..
data HpackEncoderContext = HpackEncoderContext {
    HpackEncoderContext -> HeaderList -> IO ByteString
_encodeHeaders    :: HeaderList -> IO HeaderBlockFragment
  , HpackEncoderContext -> Int -> IO ()
_applySettings    :: Size -> IO ()
  }

data DispatchHPACK = DispatchHPACK {
    DispatchHPACK -> DynamicTable
_dispatchHPACKDynamicTable          :: !DynamicTable
  }

newDispatchHPACKIO :: MonadBase IO m => Size -> m DispatchHPACK
newDispatchHPACKIO :: forall (m :: * -> *). MonadBase IO m => Int -> m DispatchHPACK
newDispatchHPACKIO Int
decoderBufSize = IO DispatchHPACK -> m DispatchHPACK
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO DispatchHPACK -> m DispatchHPACK)
-> IO DispatchHPACK -> m DispatchHPACK
forall a b. (a -> b) -> a -> b
$
    DynamicTable -> DispatchHPACK
DispatchHPACK (DynamicTable -> DispatchHPACK)
-> IO DynamicTable -> IO DispatchHPACK
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO DynamicTable
newDecoder
  where
    newDecoder :: IO DynamicTable
newDecoder = Int -> Int -> IO DynamicTable
newDynamicTableForDecoding
        Int
HPACK.defaultDynamicTableSize
        Int
decoderBufSize

data DispatchStream = DispatchStream {
    DispatchStream -> Int
_dispatchStreamId         :: !StreamId
  , DispatchStream -> Chan StreamEvent
_dispatchStreamReadEvents :: !(Chan StreamEvent)
  }

newDispatchStreamIO :: MonadBase IO m => StreamId -> m DispatchStream
newDispatchStreamIO :: forall (m :: * -> *). MonadBase IO m => Int -> m DispatchStream
newDispatchStreamIO Int
sid = IO DispatchStream -> m DispatchStream
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO DispatchStream -> m DispatchStream)
-> IO DispatchStream -> m DispatchStream
forall a b. (a -> b) -> a -> b
$
    Int -> Chan StreamEvent -> DispatchStream
DispatchStream (Int -> Chan StreamEvent -> DispatchStream)
-> IO Int -> IO (Chan StreamEvent -> DispatchStream)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
sid
                   IO (Chan StreamEvent -> DispatchStream)
-> IO (Chan StreamEvent) -> IO DispatchStream
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Chan StreamEvent)
forall (m :: * -> *) a. MonadBase IO m => m (Chan a)
newChan