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

module Network.HTTP2.Server.Run where

import UnliftIO.Async (concurrently_)

import Imports
import Network.HTTP2.Arch
import Network.HTTP2.Frame
import Network.HTTP2.Server.Types
import Network.HTTP2.Server.Worker
import Control.Exception

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

-- | Running HTTP/2 server.
run :: Config -> Server -> IO ()
run :: Config -> Server -> IO ()
run conf :: Config
conf@Config{BufferSize
Buffer
Manager
SockAddr
BufferSize -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: BufferSize
confSendAll :: ByteString -> IO ()
confReadN :: BufferSize -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> BufferSize
confSendAll :: Config -> ByteString -> IO ()
confReadN :: Config -> BufferSize -> IO ByteString
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
confMySockAddr :: Config -> SockAddr
confPeerSockAddr :: Config -> SockAddr
..} 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 -> SockAddr -> SockAddr -> IO Context
newContext RoleInfo
serverInfo BufferSize
confBufferSize SockAddr
confMySockAddr SockAddr
confPeerSockAddr
        -- Workers, worker manager and timer manager
        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
        -- The number of workers is 3.
        -- This was carefully chosen based on a lot of benchmarks.
        -- If it is 1, we cannot avoid head-of-line blocking.
        -- If it is large, huge memory is consumed and many
        -- context switches happen.
        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
        Manager -> IO () -> (Either SomeException () -> IO ()) -> IO ()
forall a b.
Manager -> IO a -> (Either SomeException a -> IO b) -> IO b
stopAfter Manager
mgr (IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ IO ()
runReceiver IO ()
runSender) ((Either SomeException () -> IO ()) -> IO ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
res -> do
          StreamTable -> Maybe SomeException -> IO ()
closeAllStreams (Context -> StreamTable
streamTable 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 e a. Exception e => e -> IO a
throwIO SomeException
err
            Right ()
x ->
              () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
x
  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

-- connClose must not be called here since Run:fork calls it
goaway :: Config -> ErrorCode -> ByteString -> IO ()
goaway :: Config -> ErrorCode -> ByteString -> IO ()
goaway Config{BufferSize
Buffer
Manager
SockAddr
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
confMySockAddr :: Config -> SockAddr
confPeerSockAddr :: Config -> SockAddr
confWriteBuffer :: Buffer
confBufferSize :: BufferSize
confSendAll :: ByteString -> IO ()
confReadN :: BufferSize -> IO ByteString
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
..} ErrorCode
etype ByteString
debugmsg = ByteString -> IO ()
confSendAll ByteString
bytestream
  where
    bytestream :: ByteString
bytestream = BufferSize -> ErrorCode -> ByteString -> ByteString
goawayFrame BufferSize
0 ErrorCode
etype ByteString
debugmsg