{-# 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.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
data ServerConfig = ServerConfig
{ ServerConfig -> Int
numberOfWorkers :: Int
, ServerConfig -> Int
connectionWindowSize :: WindowSize
, ServerConfig -> 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)
defaultServerConfig :: ServerConfig
defaultServerConfig :: ServerConfig
defaultServerConfig =
ServerConfig
{ numberOfWorkers :: Int
numberOfWorkers = Int
8
, connectionWindowSize :: Int
connectionWindowSize = Int
defaultMaxData
, settings :: Settings
settings = Settings
defaultSettings
}
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
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 ()
}
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
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
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