{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.Server.Run where
import UnliftIO.Async (concurrently_)
import qualified UnliftIO.Exception as E
import Imports
import Network.HTTP2.Arch
import Network.HTTP2.Frame
import Network.HTTP2.Server.Types
import Network.HTTP2.Server.Worker
run :: Config -> Server -> IO ()
run :: Config -> Server -> IO ()
run conf :: Config
conf@Config{BufferSize
Buffer
Manager
BufferSize -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: BufferSize
confSendAll :: ByteString -> IO ()
confReadN :: BufferSize -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> BufferSize
confSendAll :: Config -> ByteString -> IO ()
confReadN :: Config -> BufferSize -> IO ByteString
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
..} Server
server = do
Bool
ok <- IO Bool
checkPreface
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
RoleInfo
serverInfo <- IO RoleInfo
newServerInfo
Context
ctx <- RoleInfo -> BufferSize -> IO Context
newContext RoleInfo
serverInfo BufferSize
confBufferSize
Manager
mgr <- Manager -> IO Manager
start Manager
confTimeoutManager
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
BufferSize -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => BufferSize -> m a -> m ()
replicateM_ BufferSize
3 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Manager -> IO ()
spawnAction Manager
mgr
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
IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ IO ()
runReceiver IO ()
runSender IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`E.finally` Manager -> IO ()
stop Manager
mgr
where
checkPreface :: IO Bool
checkPreface = do
ByteString
preface <- BufferSize -> IO ByteString
confReadN BufferSize
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
goaway :: Config -> ErrorCode -> ByteString -> IO ()
goaway :: Config -> ErrorCode -> ByteString -> IO ()
goaway Config{BufferSize
Buffer
Manager
BufferSize -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> BufferSize
confSendAll :: Config -> ByteString -> IO ()
confReadN :: Config -> BufferSize -> IO ByteString
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
confWriteBuffer :: Buffer
confBufferSize :: BufferSize
confSendAll :: ByteString -> IO ()
confReadN :: BufferSize -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
..} ErrorCode
etype ByteString
debugmsg = ByteString -> IO ()
confSendAll ByteString
bytestream
where
bytestream :: ByteString
bytestream = BufferSize -> ErrorCode -> ByteString -> ByteString
goawayFrame BufferSize
0 ErrorCode
etype ByteString
debugmsg