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

module Network.HTTP2.Server.Run where

import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.STM
import Imports
import Network.Control (defaultMaxData)
import Network.HTTP.Semantics.IO
import Network.HTTP.Semantics.Server
import Network.HTTP.Semantics.Server.Internal
import Network.Socket (SockAddr)
import qualified System.ThreadManager as T

import Network.HTTP2.Frame
import Network.HTTP2.H2
import Network.HTTP2.Server.Worker

-- | Server configuration
data ServerConfig = ServerConfig
    { ServerConfig -> Int
numberOfWorkers :: Int
    -- ^ Deprecated field.
    , 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)

{-# DEPRECATED numberOfWorkers "No effect anymore" #-}

-- | The default server config.
--
-- >>> defaultServerConfig
-- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 16777216, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing, pingRateLimit = 10, emptyFrameRateLimit = 4, settingsRateLimit = 4, rstRateLimit = 4}}
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 ServerConfig
sconf 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
        let lnch :: Launch
lnch = Config -> Server -> Launch
runServer Config
conf Server
server
        Context
ctx <- ServerConfig -> Config -> Launch -> IO Context
setup ServerConfig
sconf Config
conf Launch
lnch
        Config -> Context -> IO ()
runH2 Config
conf Context
ctx

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

data ServerIO a = ServerIO
    { forall a. ServerIO a -> SockAddr
sioMySockAddr :: SockAddr
    , forall a. ServerIO a -> SockAddr
sioPeerSockAddr :: SockAddr
    , forall a. ServerIO a -> IO (a, Request)
sioReadRequest :: IO (a, Request)
    , forall a. ServerIO a -> a -> Response -> IO ()
sioWriteResponse :: a -> Response -> IO ()
    -- ^ 'Response' MUST be created with 'responseBuilder'.
    -- Others are not supported.
    }

-- | Launching a receiver and a sender without workers.
-- Any frames can be sent with `sioWriteBytes`.
runIO
    :: ServerConfig
    -> Config
    -> (ServerIO Stream -> IO (IO ()))
    -> IO ()
runIO :: ServerConfig -> Config -> (ServerIO Stream -> 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 Stream -> 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
        TQueue (Stream, InpObj)
inpQ <- IO (TQueue (Stream, InpObj))
forall a. IO (TQueue a)
newTQueueIO
        let lnch :: p -> Stream -> InpObj -> IO ()
lnch p
_ Stream
strm InpObj
inpObj = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Stream, InpObj) -> (Stream, InpObj) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Stream, InpObj)
inpQ (Stream
strm, InpObj
inpObj)
        Context
ctx <- ServerConfig -> Config -> Launch -> IO Context
setup ServerConfig
sconf Config
conf Launch
forall {p}. p -> Stream -> InpObj -> IO ()
lnch
        let get :: IO (Stream, Request)
get = do
                (Stream
strm, InpObj
inpObj) <- STM (Stream, InpObj) -> IO (Stream, InpObj)
forall a. STM a -> IO a
atomically (STM (Stream, InpObj) -> IO (Stream, InpObj))
-> STM (Stream, InpObj) -> IO (Stream, InpObj)
forall a b. (a -> b) -> a -> b
$ TQueue (Stream, InpObj) -> STM (Stream, InpObj)
forall a. TQueue a -> STM a
readTQueue TQueue (Stream, InpObj)
inpQ
                (Stream, Request) -> IO (Stream, Request)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream
strm, InpObj -> Request
Request InpObj
inpObj)
            putR :: Stream -> Response -> IO ()
putR Stream
strm (Response OutObj{[Header]
OutBody
TrailersMaker
outObjHeaders :: [Header]
outObjBody :: OutBody
outObjTrailers :: TrailersMaker
outObjHeaders :: OutObj -> [Header]
outObjBody :: OutObj -> OutBody
outObjTrailers :: OutObj -> TrailersMaker
..}) = do
                case OutBody
outObjBody of
                    OutBodyBuilder Builder
builder -> do
                        let next :: DynaNext
next = Builder -> DynaNext
fillBuilderBodyGetNext Builder
builder
                            otyp :: OutputType
otyp = [Header] -> Maybe DynaNext -> TrailersMaker -> OutputType
OHeader [Header]
outObjHeaders (DynaNext -> Maybe DynaNext
forall a. a -> Maybe a
Just DynaNext
next) TrailersMaker
outObjTrailers
                        Context -> Stream -> OutputType -> IO ()
enqueueOutputSIO Context
ctx Stream
strm OutputType
otyp
                    OutBody
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"Response other than OutBodyBuilder is not supported"
            serverIO :: ServerIO Stream
serverIO =
                ServerIO
                    { sioMySockAddr :: SockAddr
sioMySockAddr = SockAddr
confMySockAddr
                    , sioPeerSockAddr :: SockAddr
sioPeerSockAddr = SockAddr
confPeerSockAddr
                    , sioReadRequest :: IO (Stream, Request)
sioReadRequest = IO (Stream, Request)
get
                    , sioWriteResponse :: Stream -> Response -> IO ()
sioWriteResponse = Stream -> Response -> IO ()
putR
                    }
        IO ()
io <- ServerIO Stream -> IO (IO ())
action ServerIO Stream
serverIO
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
io (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Context -> IO ()
runH2 Config
conf Context
ctx

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 -> Launch -> IO Context
setup :: ServerConfig -> Config -> Launch -> IO Context
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
..} Launch
lnch = do
    let serverInfo :: RoleInfo
serverInfo = Launch -> RoleInfo
newServerInfo Launch
lnch
    RoleInfo
-> Config -> Int -> Int -> Settings -> Manager -> IO Context
newContext
        RoleInfo
serverInfo
        Config
conf
        Int
0
        Int
connectionWindowSize
        Settings
settings
        Manager
confTimeoutManager

runH2 :: Config -> Context -> IO ()
runH2 :: Config -> Context -> IO ()
runH2 Config
conf Context
ctx = do
    let mgr :: ThreadManager
mgr = Context -> ThreadManager
threadManager Context
ctx
        runReceiver :: IO ()
runReceiver = Context -> Config -> IO ()
frameReceiver Context
ctx Config
conf
        runSender :: IO ()
runSender = Context -> Config -> IO ()
frameSender Context
ctx Config
conf
        runBackgroundThreads :: IO ()
runBackgroundThreads = IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
runReceiver IO ()
runSender
    ThreadManager -> IO () -> (Maybe SomeException -> IO ()) -> IO ()
forall a.
ThreadManager -> IO a -> (Maybe SomeException -> IO ()) -> IO a
T.stopAfter ThreadManager
mgr IO ()
runBackgroundThreads ((Maybe SomeException -> IO ()) -> IO ())
-> (Maybe SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe SomeException
res ->
        TVar OddStreamTable
-> TVar EvenStreamTable -> Maybe SomeException -> IO ()
closeAllStreams (Context -> TVar OddStreamTable
oddStreamTable Context
ctx) (Context -> TVar EvenStreamTable
evenStreamTable Context
ctx) Maybe SomeException
res

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