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

    module Network.HTTP2.Server.Run where

    import Control.Concurrent.Async (concurrently_)
    import Control.Concurrent.STM
    import qualified Control.Exception as E
    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
        ok <- Config -> IO Bool
    checkPreface Config
    conf
        when ok $ do
            let lnch = Config -> Server -> Launch
    runServer Config
    conf Server
    server
            ctx <- setup sconf conf lnch
            runH2 conf 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
    SockAddr
    Manager
    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
    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
    ..} ServerIO Stream -> IO (IO ())
    action = do
        ok <- Config -> IO Bool
    checkPreface Config
    conf
        when ok $ do
            inpQ <- newTQueueIO
            let 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)
            ctx <- setup sconf conf lnch
            let get = do
                    (strm, 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
                    return (strm, Request inpObj)
                putR Stream
    strm (Response OutObj{[Header]
    OutBody
    TrailersMaker
    outObjHeaders :: [Header]
    outObjBody :: OutBody
    outObjTrailers :: TrailersMaker
    outObjTrailers :: OutObj -> TrailersMaker
    outObjBody :: OutObj -> OutBody
    outObjHeaders :: OutObj -> [Header]
    ..}) = 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
                        { 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 <- action serverIO
            concurrently_ io $ runH2 conf ctx

    checkPreface :: Config -> IO Bool
    checkPreface :: Config -> IO Bool
    checkPreface conf :: Config
    conf@Config{Int
    Buffer
    SockAddr
    Manager
    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
    confWriteBuffer :: Buffer
    confBufferSize :: Int
    confSendAll :: ByteString -> IO ()
    confReadN :: Int -> IO ByteString
    confPositionReadMaker :: PositionReadMaker
    confTimeoutManager :: Manager
    confMySockAddr :: SockAddr
    confPeerSockAddr :: SockAddr
    ..} = do
        preface <- Int -> IO ByteString
    confReadN Int
    connectionPrefaceLength
        if connectionPreface /= preface
            then do
                goaway conf ProtocolError "Preface mismatch"
                return False
            else return 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
    SockAddr
    Manager
    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
    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 = do
                er <- IO () -> IO (Either SomeException ())
    forall e a. Exception e => IO a -> IO (Either e a)
    E.try (IO () -> IO (Either SomeException ()))
    -> IO () -> IO (Either SomeException ())
    forall a b. (a -> b) -> a -> b
    $ IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO ()
    concurrently_ IO ()
    runReceiver IO ()
    runSender
                case er of
                    Right () -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                    Left SomeException
    e -> Config -> SomeException -> IO ()
    forall a. Config -> SomeException -> IO a
    closureServer Config
    conf SomeException
    e
        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
    SockAddr
    Manager
    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
    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