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

module Network.HTTP2.Server.Run where

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

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 = 1048576, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10}}
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 sconf :: ServerConfig
sconf@ServerConfig{Int
numberOfWorkers :: ServerConfig -> Int
numberOfWorkers :: Int
numberOfWorkers} 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
        (Context
ctx, Manager
mgr) <- ServerConfig -> Config -> IO (Context, Manager)
setup ServerConfig
sconf Config
conf
        let wc :: WorkerConf Stream
wc = Context -> WorkerConf Stream
fromContext Context
ctx
        Manager -> IO () -> IO ()
setAction Manager
mgr (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkerConf Stream -> Manager -> Server -> IO ()
forall a. WorkerConf a -> Manager -> Server -> IO ()
worker WorkerConf Stream
wc Manager
mgr Server
server
        Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
numberOfWorkers (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Manager -> IO ()
spawnAction Manager
mgr
        Config -> Context -> Manager -> IO ()
runH2 Config
conf Context
ctx Manager
mgr IO () -> [Handler IO ()] -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`catches` [(SomeException -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeException -> IO ()) -> Handler IO ())
-> (SomeException -> IO ()) -> Handler IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
ex :: SomeException) ->
                                    case SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex of
                                      Just HTTP2Error
ConnectionIsClosed -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                                      Maybe HTTP2Error
_ -> SomeException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
ex
                            ]

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

data ServerIO = ServerIO
    { ServerIO -> SockAddr
sioMySockAddr :: SockAddr
    , ServerIO -> SockAddr
sioPeerSockAddr :: SockAddr
    , ServerIO -> IO (Int, Stream, Request)
sioReadRequest :: IO (StreamId, Stream, Request)
    , ServerIO -> Stream -> Response -> IO ()
sioWriteResponse :: Stream -> Response -> IO ()
    , ServerIO -> ByteString -> IO ()
sioWriteBytes :: ByteString -> IO ()
    }

-- | Launching a receiver and a sender without workers.
-- Any frames can be sent with `sioWriteBytes`.
runIO
    :: ServerConfig
    -> Config
    -> (ServerIO -> IO (IO ()))
    -> IO ()
runIO :: ServerConfig -> Config -> (ServerIO -> 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 -> 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
        (ctx :: Context
ctx@Context{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 Stream)
DynamicTable
Settings
RoleInfo
Role
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 Stream)
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
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 Stream)
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
..}, Manager
mgr) <- ServerConfig -> Config -> IO (Context, Manager)
setup ServerConfig
sconf Config
conf
        let ServerInfo{TQueue (Input Stream)
inputQ :: TQueue (Input Stream)
inputQ :: ServerInfo -> TQueue (Input Stream)
..} = RoleInfo -> ServerInfo
toServerInfo RoleInfo
roleInfo
            get :: IO (Int, Stream, Request)
get = do
                Input Stream
strm InpObj
inObj <- STM (Input Stream) -> IO (Input Stream)
forall a. STM a -> IO a
atomically (STM (Input Stream) -> IO (Input Stream))
-> STM (Input Stream) -> IO (Input Stream)
forall a b. (a -> b) -> a -> b
$ TQueue (Input Stream) -> STM (Input Stream)
forall a. TQueue a -> STM a
readTQueue TQueue (Input Stream)
inputQ
                (Int, Stream, Request) -> IO (Int, Stream, Request)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream -> Int
streamNumber Stream
strm, Stream
strm, InpObj -> Request
Request InpObj
inObj)
            putR :: Stream -> Response -> IO ()
putR Stream
strm (Response OutObj
outObj) = do
                let out :: Output Stream
out = Stream
-> OutObj
-> OutputType
-> Maybe (TBQueue StreamingChunk)
-> IO ()
-> Output Stream
forall a.
a
-> OutObj
-> OutputType
-> Maybe (TBQueue StreamingChunk)
-> IO ()
-> Output a
Output Stream
strm OutObj
outObj OutputType
OObj Maybe (TBQueue StreamingChunk)
forall a. Maybe a
Nothing (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                TQueue (Output Stream) -> Output Stream -> IO ()
enqueueOutput TQueue (Output Stream)
outputQ Output Stream
out
            putB :: ByteString -> IO ()
putB ByteString
bs = TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [ByteString
bs]
        IO ()
io <- ServerIO -> IO (IO ())
action (ServerIO -> IO (IO ())) -> ServerIO -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ SockAddr
-> SockAddr
-> IO (Int, Stream, Request)
-> (Stream -> Response -> IO ())
-> (ByteString -> IO ())
-> ServerIO
ServerIO SockAddr
confMySockAddr SockAddr
confPeerSockAddr IO (Int, Stream, Request)
get Stream -> Response -> IO ()
putR ByteString -> IO ()
putB
        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 -> Manager -> IO ()
runH2 Config
conf Context
ctx Manager
mgr

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 -> IO (Context, Manager)
setup :: ServerConfig -> Config -> IO (Context, Manager)
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
..} = do
    RoleInfo
serverInfo <- IO RoleInfo
newServerInfo
    Context
ctx <-
        RoleInfo -> Config -> Int -> Int -> Settings -> IO Context
newContext
            RoleInfo
serverInfo
            Config
conf
            Int
0
            Int
connectionWindowSize
            Settings
settings
    -- Workers, worker manager and timer manager
    Manager
mgr <- Manager -> IO Manager
start Manager
confTimeoutManager
    (Context, Manager) -> IO (Context, Manager)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context
ctx, Manager
mgr)

runH2 :: Config -> Context -> Manager -> IO ()
runH2 :: Config -> Context -> Manager -> IO ()
runH2 Config
conf Context
ctx Manager
mgr = do
    let runReceiver :: IO ()
runReceiver = Context -> Config -> IO ()
frameReceiver Context
ctx Config
conf
        runSender :: IO ()
runSender = Context -> Config -> Manager -> IO ()
frameSender Context
ctx Config
conf Manager
mgr
        runBackgroundThreads :: IO ()
runBackgroundThreads = IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ IO ()
runReceiver IO ()
runSender
    Manager -> IO () -> (Either SomeException () -> IO ()) -> IO ()
forall a b.
Manager -> IO a -> (Either SomeException a -> IO b) -> IO b
stopAfter Manager
mgr IO ()
runBackgroundThreads ((Either SomeException () -> IO ()) -> IO ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
res -> do
        TVar OddStreamTable
-> TVar EvenStreamTable -> Maybe SomeException -> IO ()
closeAllStreams (Context -> TVar OddStreamTable
oddStreamTable Context
ctx) (Context -> TVar EvenStreamTable
evenStreamTable Context
ctx) (Maybe SomeException -> IO ()) -> Maybe SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$
            (SomeException -> Maybe SomeException)
-> (() -> Maybe SomeException)
-> Either SomeException ()
-> Maybe SomeException
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (Maybe SomeException -> () -> Maybe SomeException
forall a b. a -> b -> a
const Maybe SomeException
forall a. Maybe a
Nothing) Either SomeException ()
res
        case Either SomeException ()
res of
            Left SomeException
err ->
                SomeException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
err
            Right ()
x ->
                () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
x

-- 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