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

module Network.HTTP2.Server.Run where

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

import Network.HTTP2.Frame
import Network.HTTP2.H2
import Network.HTTP2.Server.Types
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerConfig -> ServerConfig -> Bool
$c/= :: ServerConfig -> ServerConfig -> Bool
== :: ServerConfig -> ServerConfig -> Bool
$c== :: ServerConfig -> ServerConfig -> Bool
Eq, Int -> ServerConfig -> ShowS
[ServerConfig] -> ShowS
ServerConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerConfig] -> ShowS
$cshowList :: [ServerConfig] -> ShowS
show :: ServerConfig -> String
$cshow :: ServerConfig -> String
showsPrec :: Int -> ServerConfig -> ShowS
$cshowsPrec :: Int -> 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}}
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 :: Int
numberOfWorkers :: ServerConfig -> Int
numberOfWorkers} Config
conf Server
server = do
    Bool
ok <- Config -> IO Bool
checkPreface Config
conf
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok 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 forall a b. (a -> b) -> a -> b
$ forall a. WorkerConf a -> Manager -> Server -> IO ()
worker WorkerConf Stream
wc Manager
mgr Server
server
        forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
numberOfWorkers forall a b. (a -> b) -> a -> b
$ Manager -> IO ()
spawnAction Manager
mgr
        Config -> Context -> Manager -> IO ()
runH2 Config
conf Context
ctx Manager
mgr

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

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 ()
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
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
..} ServerIO -> IO (IO ())
action = do
    Bool
ok <- Config -> IO Bool
checkPreface Config
conf
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok 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
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 Stream)
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
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
rstRate :: Rate
emptyFrameRate :: Rate
settingsRate :: Rate
pingRate :: Rate
rxFlow :: IORef RxFlow
txFlow :: TVar TxFlow
decodeDynamicTable :: DynamicTable
encodeDynamicTable :: DynamicTable
controlQ :: TQueue Control
outputQStreamID :: TVar Int
outputQ :: TQueue (Output Stream)
outputBufferLimit :: IORef Int
peerStreamId :: IORef Int
myStreamId :: TVar Int
continued :: IORef (Maybe Int)
evenStreamTable :: TVar EvenStreamTable
oddStreamTable :: TVar OddStreamTable
peerSettings :: IORef Settings
myFirstSettings :: IORef Bool
mySettings :: Settings
roleInfo :: RoleInfo
role :: Role
..}, Manager
mgr) <- ServerConfig -> Config -> IO (Context, Manager)
setup ServerConfig
sconf Config
conf
        let ServerInfo{TQueue (Input Stream)
inputQ :: ServerInfo -> TQueue (Input Stream)
inputQ :: TQueue (Input Stream)
..} = RoleInfo -> ServerInfo
toServerInfo RoleInfo
roleInfo
            get :: IO (Int, Stream, Request)
get = do
                Input Stream
strm InpObj
inObj <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> STM a
readTQueue TQueue (Input Stream)
inputQ
                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 = forall a.
a
-> OutObj
-> OutputType
-> Maybe (TBQueue StreamingChunk)
-> IO ()
-> Output a
Output Stream
strm OutObj
outObj OutputType
OObj forall a. Maybe a
Nothing (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 forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [ByteString] -> Control
CFrames forall a. Maybe a
Nothing [ByteString
bs]
        IO ()
io <- ServerIO -> IO (IO ())
action 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
        forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ 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 ()
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
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
..} = do
    ByteString
preface <- Int -> IO ByteString
confReadN Int
connectionPrefaceLength
    if ByteString
connectionPreface forall a. Eq a => a -> a -> Bool
/= ByteString
preface
        then do
            Config -> ErrorCode -> ByteString -> IO ()
goaway Config
conf ErrorCode
ProtocolError ByteString
"Preface mismatch"
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else 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
settings :: Settings
connectionWindowSize :: Int
numberOfWorkers :: Int
settings :: ServerConfig -> Settings
connectionWindowSize :: ServerConfig -> Int
numberOfWorkers :: ServerConfig -> Int
..} conf :: Config
conf@Config{Int
Buffer
Manager
SockAddr
Int -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
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
..} = 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
    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 = forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ IO ()
runReceiver IO ()
runSender
    forall a b.
Manager -> IO a -> (Either SomeException a -> IO b) -> IO b
stopAfter Manager
mgr IO ()
runBackgroundThreads 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) forall a b. (a -> b) -> a -> b
$
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> Maybe a
Just (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) Either SomeException ()
res
        case Either SomeException ()
res of
            Left SomeException
err ->
                forall e a. Exception e => e -> IO a
throwIO SomeException
err
            Right ()
x ->
                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 ()
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
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
..} ErrorCode
etype ByteString
debugmsg = ByteString -> IO ()
confSendAll ByteString
bytestream
  where
    bytestream :: ByteString
bytestream = Int -> ErrorCode -> ByteString -> ByteString
goawayFrame Int
0 ErrorCode
etype ByteString
debugmsg