{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.HTTP2.Client.Run where

import Control.Concurrent.Async
import Control.Concurrent
import qualified Control.Exception as E
import Data.IORef (writeIORef)

import Network.HTTP2.Arch
import Network.HTTP2.Client.Types
import Network.HTTP2.Frame

-- | Client configuration
data ClientConfig = ClientConfig {
    ClientConfig -> Scheme
scheme     :: Scheme    -- ^ https or http
  , ClientConfig -> Scheme
authority  :: Authority -- ^ Server name
  , ClientConfig -> Int
cacheLimit :: Int       -- ^ How many pushed responses are contained in the cache
  }

-- | Running HTTP/2 client.
run :: ClientConfig -> Config -> Client a -> IO a
run :: ClientConfig -> Config -> Client a -> IO a
run ClientConfig{Int
Scheme
cacheLimit :: Int
authority :: Scheme
scheme :: Scheme
cacheLimit :: ClientConfig -> Int
authority :: ClientConfig -> Scheme
scheme :: ClientConfig -> Scheme
..} conf :: Config
conf@Config{Int
Buffer
Manager
Int -> IO Scheme
PositionReadMaker
Scheme -> IO ()
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO Scheme
confSendAll :: Config -> Scheme -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO Scheme
confSendAll :: Scheme -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
..} Client a
client = do
    RoleInfo
clientInfo <- Scheme -> Scheme -> Int -> IO RoleInfo
newClientInfo Scheme
scheme Scheme
authority Int
cacheLimit
    Context
ctx <- RoleInfo -> IO Context
newContext RoleInfo
clientInfo
    Manager
mgr <- Manager -> IO Manager
start Manager
confTimeoutManager
    let runBackgroundThreads :: IO b
runBackgroundThreads = do
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_
                (Context -> (Int -> IO Scheme) -> IO ()
frameReceiver Context
ctx Int -> IO Scheme
confReadN)
                (Context -> Config -> Manager -> IO ()
frameSender Context
ctx Config
conf Manager
mgr)
            HTTP2Error -> IO b
forall e a. Exception e => e -> IO a
E.throwIO (ErrorCodeId -> Scheme -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError Scheme
"connection terminated")
    Config -> Context -> IO ()
exchangeSettings Config
conf Context
ctx
    (Either a a -> a) -> IO (Either a a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id) (IO (Either a a) -> IO a) -> IO (Either a a) -> IO a
forall a b. (a -> b) -> a -> b
$
        IO a -> IO a -> IO (Either a a)
forall a b. IO a -> IO b -> IO (Either a b)
race IO a
forall b. IO b
runBackgroundThreads (Client a
client (Context
-> Scheme -> Scheme -> Request -> (Response -> IO a) -> IO a
forall a.
Context
-> Scheme -> Scheme -> Request -> (Response -> IO a) -> IO a
sendRequest Context
ctx Scheme
scheme Scheme
authority))
            IO (Either a a) -> IO () -> IO (Either a a)
forall a b. IO a -> IO b -> IO a
`E.finally` Manager -> IO ()
stop Manager
mgr

sendRequest :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a
sendRequest :: Context
-> Scheme -> Scheme -> Request -> (Response -> IO a) -> IO a
sendRequest ctx :: Context
ctx@Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
..} Scheme
scheme Scheme
auth (Request OutObj
req) Response -> IO a
processResponse = do
    let hdr :: [Header]
hdr = OutObj -> [Header]
outObjHeaders OutObj
req
        Just Scheme
method = HeaderName -> [Header] -> Maybe Scheme
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
":method" [Header]
hdr
        Just Scheme
path   = HeaderName -> [Header] -> Maybe Scheme
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
":path" [Header]
hdr
    Maybe Stream
mstrm0 <- Scheme -> Scheme -> RoleInfo -> IO (Maybe Stream)
lookupCache Scheme
method Scheme
path RoleInfo
roleInfo
    Stream
strm <- case Maybe Stream
mstrm0 of
      Maybe Stream
Nothing -> do
          let hdr' :: [Header]
hdr' = (HeaderName
":scheme", Scheme
scheme)
                   Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: (HeaderName
":authority", Scheme
auth)
                   Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
hdr
              req' :: OutObj
req' = OutObj
req { outObjHeaders :: [Header]
outObjHeaders = [Header]
hdr' }
          Int
sid <- Context -> IO Int
getMyNewStreamId Context
ctx
          Stream
newstrm <- Context -> Int -> FrameTypeId -> IO Stream
openStream Context
ctx Int
sid FrameTypeId
FrameHeaders
          TQueue (Output Stream) -> Output Stream -> IO ()
enqueueOutput TQueue (Output Stream)
outputQ (Output Stream -> IO ()) -> Output Stream -> IO ()
forall a b. (a -> b) -> a -> b
$ Stream
-> OutObj
-> OutputType
-> Maybe (TBQueue StreamingChunk)
-> IO ()
-> Output Stream
forall a.
a
-> OutObj
-> OutputType
-> Maybe (TBQueue StreamingChunk)
-> IO ()
-> Output a
Output Stream
newstrm OutObj
req' OutputType
OObj Maybe (TBQueue StreamingChunk)
forall a. Maybe a
Nothing (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          Stream -> IO Stream
forall (m :: * -> *) a. Monad m => a -> m a
return Stream
newstrm
      Just Stream
strm0 -> Stream -> IO Stream
forall (m :: * -> *) a. Monad m => a -> m a
return Stream
strm0
    InpObj
rsp <- MVar InpObj -> IO InpObj
forall a. MVar a -> IO a
takeMVar (MVar InpObj -> IO InpObj) -> MVar InpObj -> IO InpObj
forall a b. (a -> b) -> a -> b
$ Stream -> MVar InpObj
streamInput Stream
strm
    Response -> IO a
processResponse (Response -> IO a) -> Response -> IO a
forall a b. (a -> b) -> a -> b
$ InpObj -> Response
Response InpObj
rsp

exchangeSettings :: Config -> Context -> IO ()
exchangeSettings :: Config -> Context -> IO ()
exchangeSettings Config{Int
Buffer
Manager
Int -> IO Scheme
PositionReadMaker
Scheme -> IO ()
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO Scheme
confSendAll :: Scheme -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO Scheme
confSendAll :: Config -> Scheme -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} Context{TVar Int
IORef Bool
IORef Int
IORef (Maybe Int)
IORef Settings
TQueue Control
TQueue (Output Stream)
DynamicTable
Rate
StreamTable
RoleInfo
Role
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
connectionWindow :: TVar Int
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQ :: TQueue (Output Stream)
peerStreamId :: IORef Int
myStreamId :: IORef Int
continued :: IORef (Maybe Int)
concurrency :: IORef Int
streamTable :: StreamTable
firstSettings :: IORef Bool
http2settings :: IORef Settings
roleInfo :: RoleInfo
role :: Role
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
connectionWindow :: Context -> TVar Int
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQ :: Context -> TQueue (Output Stream)
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> IORef Int
continued :: Context -> IORef (Maybe Int)
concurrency :: Context -> IORef Int
streamTable :: Context -> StreamTable
firstSettings :: Context -> IORef Bool
http2settings :: Context -> IORef Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} = do
    Scheme -> IO ()
confSendAll Scheme
connectionPreface
    let setframe :: Control
setframe = Scheme -> SettingsList -> Control
CSettings Scheme
initialFrame [] -- fixme alist
    IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
firstSettings Bool
True
    TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe