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

module Network.HTTP2.Server.Run where

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 UnliftIO.Async (concurrently_)

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

-- | Server configuration
data ServerConfig = ServerConfig
    { ServerConfig -> Int
numberOfWorkers :: Int
    -- ^ The number of workers
    , 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)

-- | 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
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
..} 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
DynamicTable
Rate
TQueue Control
TQueue Output
Manager
Settings
SockAddr
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
senderDone :: Context -> TVar Bool
peerSockAddr :: Context -> SockAddr
mySockAddr :: Context -> SockAddr
rstRate :: Context -> Rate
emptyFrameRate :: Context -> Rate
settingsRate :: Context -> Rate
pingRate :: Context -> Rate
rxFlow :: Context -> IORef RxFlow
txFlow :: Context -> TVar TxFlow
decodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: Context -> DynamicTable
controlQ :: Context -> TQueue Control
outputQStreamID :: Context -> TVar Int
outputQ :: Context -> TQueue Output
outputBufferLimit :: Context -> IORef Int
peerStreamId :: Context -> IORef Int
myStreamId :: Context -> TVar Int
continued :: Context -> IORef (Maybe Int)
evenStreamTable :: Context -> TVar EvenStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
peerSettings :: Context -> IORef Settings
myFirstSettings :: Context -> IORef Bool
mySettings :: Context -> Settings
roleInfo :: Context -> RoleInfo
role :: Context -> Role
..} <- 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
outObjBody :: OutObj -> OutBody
outObjHeaders :: OutObj -> [Header]
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 (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
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 ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
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 ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
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 (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
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 ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
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