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

module Network.HTTP2.Server.Run where

import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.STM
import Imports
import Network.Control (defaultMaxData)
import Network.HTTP.Semantics.IO
import Network.HTTP.Semantics.Server
import Network.HTTP.Semantics.Server.Internal
import Network.Socket (SockAddr)

import Network.HTTP2.Frame
import Network.HTTP2.H2
import Network.HTTP2.Server.Worker

-- | Server configuration
data ServerConfig = ServerConfig
    { ServerConfig -> Int
numberOfWorkers :: Int
    -- ^ Deprecated field.
    , ServerConfig -> Int
connectionWindowSize :: WindowSize
    -- ^ The window size of incoming streams
    , ServerConfig -> Settings
settings :: Settings
    -- ^ Settings
    }
    deriving (ServerConfig -> ServerConfig -> Bool
(ServerConfig -> ServerConfig -> Bool)
-> (ServerConfig -> ServerConfig -> Bool) -> Eq ServerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerConfig -> ServerConfig -> Bool
== :: ServerConfig -> ServerConfig -> Bool
$c/= :: ServerConfig -> ServerConfig -> Bool
/= :: ServerConfig -> ServerConfig -> Bool
Eq, Int -> ServerConfig -> ShowS
[ServerConfig] -> ShowS
ServerConfig -> String
(Int -> ServerConfig -> ShowS)
-> (ServerConfig -> String)
-> ([ServerConfig] -> ShowS)
-> Show ServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerConfig -> ShowS
showsPrec :: Int -> ServerConfig -> ShowS
$cshow :: ServerConfig -> String
show :: ServerConfig -> String
$cshowList :: [ServerConfig] -> ShowS
showList :: [ServerConfig] -> ShowS
Show)

{-# DEPRECATED numberOfWorkers "No effect anymore" #-}

-- | The default server config.
--
-- >>> defaultServerConfig
-- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}}
defaultServerConfig :: ServerConfig
defaultServerConfig :: ServerConfig
defaultServerConfig =
    ServerConfig
        { numberOfWorkers :: Int
numberOfWorkers = Int
8
        , connectionWindowSize :: Int
connectionWindowSize = Int
defaultMaxData
        , settings :: Settings
settings = Settings
defaultSettings
        }

----------------------------------------------------------------

-- | Running HTTP/2 server.
run :: ServerConfig -> Config -> Server -> IO ()
run :: ServerConfig -> Config -> Server -> IO ()
run ServerConfig
sconf Config
conf Server
server = do
    Bool
ok <- Config -> IO Bool
checkPreface Config
conf
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let lnch :: Context -> Stream -> InpObj -> IO ()
lnch Context
ctx Stream
strm InpObj
inpObj = do
                let label :: String
label = String
"H2 worker for stream " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Stream -> Int
streamNumber Stream
strm)
                Manager -> String -> IO () -> IO ()
forkManaged (Context -> Manager
threadManager Context
ctx) String
label (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Config -> Server -> Context -> Stream -> InpObj -> IO ()
worker Config
conf Server
server Context
ctx Stream
strm InpObj
inpObj
        Context
ctx <- ServerConfig
-> Config -> (Context -> Stream -> InpObj -> IO ()) -> IO Context
setup ServerConfig
sconf Config
conf Context -> Stream -> InpObj -> IO ()
lnch
        Config -> Context -> IO ()
runH2 Config
conf Context
ctx

----------------------------------------------------------------

data ServerIO a = ServerIO
    { forall a. ServerIO a -> SockAddr
sioMySockAddr :: SockAddr
    , forall a. ServerIO a -> SockAddr
sioPeerSockAddr :: SockAddr
    , forall a. ServerIO a -> IO (a, Request)
sioReadRequest :: IO (a, Request)
    , forall a. ServerIO a -> a -> Response -> IO ()
sioWriteResponse :: a -> Response -> IO ()
    -- ^ 'Response' MUST be created with 'responseBuilder'.
    -- Others are not supported.
    }

-- | Launching a receiver and a sender without workers.
-- Any frames can be sent with `sioWriteBytes`.
runIO
    :: ServerConfig
    -> Config
    -> (ServerIO Stream -> IO (IO ()))
    -> IO ()
runIO :: ServerConfig -> Config -> (ServerIO Stream -> IO (IO ())) -> IO ()
runIO ServerConfig
sconf conf :: Config
conf@Config{Int
Buffer
Manager
SockAddr
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: ByteString -> IO ()
confReadN :: Int -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> Int
confSendAll :: Config -> ByteString -> IO ()
confReadN :: Config -> Int -> IO ByteString
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
confMySockAddr :: Config -> SockAddr
confPeerSockAddr :: Config -> SockAddr
..} ServerIO Stream -> IO (IO ())
action = do
    Bool
ok <- Config -> IO Bool
checkPreface Config
conf
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        TQueue (Stream, InpObj)
inpQ <- IO (TQueue (Stream, InpObj))
forall a. IO (TQueue a)
newTQueueIO
        let lnch :: p -> Stream -> InpObj -> IO ()
lnch p
_ Stream
strm InpObj
inpObj = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Stream, InpObj) -> (Stream, InpObj) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Stream, InpObj)
inpQ (Stream
strm, InpObj
inpObj)
        ctx :: Context
ctx@Context{TVar Bool
TVar Int
TVar TxFlow
TVar EvenStreamTable
TVar OddStreamTable
IORef Bool
IORef Int
IORef (Maybe Int)
IORef RxFlow
IORef Settings
SockAddr
Rate
TQueue Control
TQueue Output
DynamicTable
Manager
Settings
RoleInfo
Role
threadManager :: Context -> Manager
role :: Role
roleInfo :: RoleInfo
mySettings :: Settings
myFirstSettings :: IORef Bool
peerSettings :: IORef Settings
oddStreamTable :: TVar OddStreamTable
evenStreamTable :: TVar EvenStreamTable
continued :: IORef (Maybe Int)
myStreamId :: TVar Int
peerStreamId :: IORef Int
outputBufferLimit :: IORef Int
outputQ :: TQueue Output
outputQStreamID :: TVar Int
controlQ :: TQueue Control
encodeDynamicTable :: DynamicTable
decodeDynamicTable :: DynamicTable
txFlow :: TVar TxFlow
rxFlow :: IORef RxFlow
pingRate :: Rate
settingsRate :: Rate
emptyFrameRate :: Rate
rstRate :: Rate
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
threadManager :: Manager
senderDone :: TVar Bool
role :: Context -> Role
roleInfo :: Context -> RoleInfo
mySettings :: Context -> Settings
myFirstSettings :: Context -> IORef Bool
peerSettings :: Context -> IORef Settings
oddStreamTable :: Context -> TVar OddStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
continued :: Context -> IORef (Maybe Int)
myStreamId :: Context -> TVar Int
peerStreamId :: Context -> IORef Int
outputBufferLimit :: Context -> IORef Int
outputQ :: Context -> TQueue Output
outputQStreamID :: Context -> TVar Int
controlQ :: Context -> TQueue Control
encodeDynamicTable :: Context -> DynamicTable
decodeDynamicTable :: Context -> DynamicTable
txFlow :: Context -> TVar TxFlow
rxFlow :: Context -> IORef RxFlow
pingRate :: Context -> Rate
settingsRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
rstRate :: Context -> Rate
mySockAddr :: Context -> SockAddr
peerSockAddr :: Context -> SockAddr
senderDone :: Context -> TVar Bool
..} <- ServerConfig
-> Config -> (Context -> Stream -> InpObj -> IO ()) -> IO Context
setup ServerConfig
sconf Config
conf Context -> Stream -> InpObj -> IO ()
forall {p}. p -> Stream -> InpObj -> IO ()
lnch
        let get :: IO (Stream, Request)
get = do
                (Stream
strm, InpObj
inpObj) <- STM (Stream, InpObj) -> IO (Stream, InpObj)
forall a. STM a -> IO a
atomically (STM (Stream, InpObj) -> IO (Stream, InpObj))
-> STM (Stream, InpObj) -> IO (Stream, InpObj)
forall a b. (a -> b) -> a -> b
$ TQueue (Stream, InpObj) -> STM (Stream, InpObj)
forall a. TQueue a -> STM a
readTQueue TQueue (Stream, InpObj)
inpQ
                (Stream, Request) -> IO (Stream, Request)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream
strm, InpObj -> Request
Request InpObj
inpObj)
            putR :: Stream -> Response -> IO ()
putR Stream
strm (Response OutObj{[Header]
OutBody
TrailersMaker
outObjHeaders :: [Header]
outObjBody :: OutBody
outObjTrailers :: TrailersMaker
outObjHeaders :: OutObj -> [Header]
outObjBody :: OutObj -> OutBody
outObjTrailers :: OutObj -> TrailersMaker
..}) = do
                case OutBody
outObjBody of
                    OutBodyBuilder Builder
builder -> do
                        let next :: DynaNext
next = Builder -> DynaNext
fillBuilderBodyGetNext Builder
builder
                            sync :: p -> m Bool
sync p
_ = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                            out :: OutputType
out = [Header] -> Maybe DynaNext -> TrailersMaker -> OutputType
OHeader [Header]
outObjHeaders (DynaNext -> Maybe DynaNext
forall a. a -> Maybe a
Just DynaNext
next) TrailersMaker
outObjTrailers
                        TQueue Output -> Output -> IO ()
enqueueOutput TQueue Output
outputQ (Output -> IO ()) -> Output -> IO ()
forall a b. (a -> b) -> a -> b
$ Stream -> OutputType -> (Maybe OutputType -> IO Bool) -> Output
Output Stream
strm OutputType
out Maybe OutputType -> IO Bool
forall {m :: * -> *} {p}. Monad m => p -> m Bool
sync
                    OutBody
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"Response other than OutBodyBuilder is not supported"
            serverIO :: ServerIO Stream
serverIO =
                ServerIO
                    { sioMySockAddr :: SockAddr
sioMySockAddr = SockAddr
confMySockAddr
                    , sioPeerSockAddr :: SockAddr
sioPeerSockAddr = SockAddr
confPeerSockAddr
                    , sioReadRequest :: IO (Stream, Request)
sioReadRequest = IO (Stream, Request)
get
                    , sioWriteResponse :: Stream -> Response -> IO ()
sioWriteResponse = Stream -> Response -> IO ()
putR
                    }
        IO ()
io <- ServerIO Stream -> IO (IO ())
action ServerIO Stream
serverIO
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
io (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Context -> IO ()
runH2 Config
conf Context
ctx

checkPreface :: Config -> IO Bool
checkPreface :: Config -> IO Bool
checkPreface conf :: Config
conf@Config{Int
Buffer
Manager
SockAddr
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> Int
confSendAll :: Config -> ByteString -> IO ()
confReadN :: Config -> Int -> IO ByteString
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
confMySockAddr :: Config -> SockAddr
confPeerSockAddr :: Config -> SockAddr
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: ByteString -> IO ()
confReadN :: Int -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
..} = do
    ByteString
preface <- Int -> IO ByteString
confReadN Int
connectionPrefaceLength
    if ByteString
connectionPreface ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
preface
        then do
            Config -> ErrorCode -> ByteString -> IO ()
goaway Config
conf ErrorCode
ProtocolError ByteString
"Preface mismatch"
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

setup :: ServerConfig -> Config -> Launch -> IO Context
setup :: ServerConfig
-> Config -> (Context -> Stream -> InpObj -> IO ()) -> IO Context
setup ServerConfig{Int
Settings
numberOfWorkers :: ServerConfig -> Int
connectionWindowSize :: ServerConfig -> Int
settings :: ServerConfig -> Settings
numberOfWorkers :: Int
connectionWindowSize :: Int
settings :: Settings
..} conf :: Config
conf@Config{Int
Buffer
Manager
SockAddr
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> Int
confSendAll :: Config -> ByteString -> IO ()
confReadN :: Config -> Int -> IO ByteString
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
confMySockAddr :: Config -> SockAddr
confPeerSockAddr :: Config -> SockAddr
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: ByteString -> IO ()
confReadN :: Int -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
..} Context -> Stream -> InpObj -> IO ()
lnch = do
    let serverInfo :: RoleInfo
serverInfo = (Context -> Stream -> InpObj -> IO ()) -> RoleInfo
newServerInfo Context -> Stream -> InpObj -> IO ()
lnch
    RoleInfo
-> Config -> Int -> Int -> Settings -> Manager -> IO Context
newContext
        RoleInfo
serverInfo
        Config
conf
        Int
0
        Int
connectionWindowSize
        Settings
settings
        Manager
confTimeoutManager

runH2 :: Config -> Context -> IO ()
runH2 :: Config -> Context -> IO ()
runH2 Config
conf Context
ctx = do
    let mgr :: Manager
mgr = Context -> Manager
threadManager Context
ctx
        runReceiver :: IO ()
runReceiver = Context -> Config -> IO ()
frameReceiver Context
ctx Config
conf
        runSender :: IO ()
runSender = Context -> Config -> IO ()
frameSender Context
ctx Config
conf
        runBackgroundThreads :: IO ()
runBackgroundThreads = IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
runReceiver IO ()
runSender
    Manager -> IO () -> (Maybe SomeException -> IO ()) -> IO ()
forall a. Manager -> IO a -> (Maybe SomeException -> IO ()) -> IO a
stopAfter Manager
mgr IO ()
runBackgroundThreads ((Maybe SomeException -> IO ()) -> IO ())
-> (Maybe SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe SomeException
res ->
        TVar OddStreamTable
-> TVar EvenStreamTable -> Maybe SomeException -> IO ()
closeAllStreams (Context -> TVar OddStreamTable
oddStreamTable Context
ctx) (Context -> TVar EvenStreamTable
evenStreamTable Context
ctx) Maybe SomeException
res

-- connClose must not be called here since Run:fork calls it
goaway :: Config -> ErrorCode -> ByteString -> IO ()
goaway :: Config -> ErrorCode -> ByteString -> IO ()
goaway Config{Int
Buffer
Manager
SockAddr
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> Int
confSendAll :: Config -> ByteString -> IO ()
confReadN :: Config -> Int -> IO ByteString
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
confMySockAddr :: Config -> SockAddr
confPeerSockAddr :: Config -> SockAddr
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: ByteString -> IO ()
confReadN :: Int -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
..} ErrorCode
etype ByteString
debugmsg = ByteString -> IO ()
confSendAll ByteString
bytestream
  where
    bytestream :: ByteString
bytestream = Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
0 ErrorCode
etype ByteString
debugmsg