    {-# LANGUAGE CPP #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE ScopedTypeVariables #-}

    module Network.Wai.Handler.Warp.HTTP2 (
        http2
      , http2server
      ) where

    import qualified Data.ByteString as BS
    import Data.IORef (IORef, newIORef, writeIORef, readIORef)
    import qualified Data.IORef as I
    import qualified Network.HTTP2.Frame as H2
    import qualified Network.HTTP2.Server as H2
    import Network.Socket (SockAddr)
    import Network.Socket.BufferPool
    import Network.Wai
    import Network.Wai.Internal (ResponseReceived(..))
    import qualified System.TimeManager as T
    import qualified UnliftIO

    import Network.Wai.Handler.Warp.HTTP2.File
    import Network.Wai.Handler.Warp.HTTP2.PushPromise
    import Network.Wai.Handler.Warp.HTTP2.Request
    import Network.Wai.Handler.Warp.HTTP2.Response
    import Network.Wai.Handler.Warp.Imports
    import qualified Network.Wai.Handler.Warp.Settings as S
    import Network.Wai.Handler.Warp.Types

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

    http2 :: S.Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> ByteString -> IO ()
    http2 :: Settings
    -> InternalInfo
    -> Connection
    -> Transport
    -> Application
    -> SockAddr
    -> Handle
    -> ByteString
    -> IO ()
    http2 Settings
    settings InternalInfo
    ii Connection
    conn Transport
    transport Application
    app SockAddr
    peersa Handle
    th ByteString
    bs = do
        IORef Bool
    istatus <- Bool -> IO (IORef Bool)
    forall a. a -> IO (IORef a)
    newIORef Bool
    False
        RecvN
    rawRecvN <- ByteString -> Recv -> IO RecvN
    makeRecvN ByteString
    bs (Recv -> IO RecvN) -> Recv -> IO RecvN
    forall a b. (a -> b) -> a -> b
    $ Connection -> Recv
    connRecv Connection
    conn
        WriteBuffer
    writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
    forall a. IORef a -> IO a
    readIORef (IORef WriteBuffer -> IO WriteBuffer)
    -> IORef WriteBuffer -> IO WriteBuffer
    forall a b. (a -> b) -> a -> b
    $ Connection -> IORef WriteBuffer
    connWriteBuffer Connection
    conn
        -- This thread becomes the sender in http2 library.
        -- In the case of event source, one request comes and one
        -- worker gets busy. But it is likely that the receiver does
        -- not receive any data at all while the sender is sending
        -- output data from the worker. It's not good enough to tickle
        -- the time handler in the receiver only. So, we should tickle
        -- the time handler in both the receiver and the sender.
        let recvN :: RecvN
    recvN = Handle -> IORef Bool -> Int -> RecvN -> RecvN
    wrappedRecvN Handle
    th IORef Bool
    istatus (Settings -> Int
    S.settingsSlowlorisSize Settings
    settings) RecvN
    rawRecvN
            sendBS :: ByteString -> IO ()
    sendBS ByteString
    x = Connection -> ByteString -> IO ()
    connSendAll Connection
    conn ByteString
    x IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    T.tickle Handle
    th
            conf :: Config
    conf = H2.Config {
                confWriteBuffer :: Buffer
    confWriteBuffer       = WriteBuffer -> Buffer
    bufBuffer WriteBuffer
    writeBuffer
              , confBufferSize :: Int
    confBufferSize        = WriteBuffer -> Int
    bufSize WriteBuffer
    writeBuffer
              , confSendAll :: ByteString -> IO ()
    confSendAll           = ByteString -> IO ()
    sendBS
              , confReadN :: RecvN
    confReadN             = RecvN
    recvN
              , confPositionReadMaker :: PositionReadMaker
    confPositionReadMaker = InternalInfo -> PositionReadMaker
    pReadMaker InternalInfo
    ii
              , confTimeoutManager :: Manager
    confTimeoutManager    = InternalInfo -> Manager
    timeoutManager InternalInfo
    ii
    #if MIN_VERSION_http2(4,2,0)
              , confMySockAddr :: SockAddr
    confMySockAddr        = Connection -> SockAddr
    connMySockAddr Connection
    conn
              , confPeerSockAddr :: SockAddr
    confPeerSockAddr      = SockAddr
    peersa
    #endif
              }
        IO ()
    checkTLS
        Connection -> Bool -> IO ()
    setConnHTTP2 Connection
    conn Bool
    True
        ServerConfig -> Config -> Server -> IO ()
    H2.run ServerConfig
    H2.defaultServerConfig Config
    conf (Server -> IO ()) -> Server -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Settings
    -> InternalInfo -> Transport -> SockAddr -> Application -> Server
    http2server Settings
    settings InternalInfo
    ii Transport
    transport SockAddr
    peersa Application
    app
      where
        checkTLS :: IO ()
    checkTLS = case Transport
    transport of
            Transport
    TCP -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () -- direct
            Transport
    tls -> Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Transport -> Bool
    tls12orLater Transport
    tls) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Connection -> ErrorCodeId -> ByteString -> IO ()
    goaway Connection
    conn ErrorCodeId
    H2.InadequateSecurity ByteString
    "Weak TLS"
        tls12orLater :: Transport -> Bool
    tls12orLater Transport
    tls = Transport -> Int
    tlsMajorVersion Transport
    tls Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    3 Bool -> Bool -> Bool
    && Transport -> Int
    tlsMinorVersion Transport
    tls Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    3

    -- | Converting WAI application to the server type of http2 library.
    --
    -- Since 3.3.11
    http2server :: S.Settings
                -> InternalInfo
                -> Transport
                -> SockAddr
                -> Application
                -> H2.Server
    http2server :: Settings
    -> InternalInfo -> Transport -> SockAddr -> Application -> Server
    http2server Settings
    settings InternalInfo
    ii Transport
    transport SockAddr
    addr Application
    app Request
    h2req0 Aux
    aux0 Response -> [PushPromise] -> IO ()
    response = do
        Request
    req <- Request -> Aux -> IO Request
    toWAIRequest Request
    h2req0 Aux
    aux0
        IORef (Maybe (Response, [PushPromise], Status))
    ref <- Maybe (Response, [PushPromise], Status)
    -> IO (IORef (Maybe (Response, [PushPromise], Status)))
    forall a. a -> IO (IORef a)
    I.newIORef Maybe (Response, [PushPromise], Status)
    forall a. Maybe a
    Nothing
        Either SomeException ResponseReceived
    eResponseReceived <- IO ResponseReceived -> IO (Either SomeException ResponseReceived)
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    m a -> m (Either SomeException a)
    UnliftIO.tryAny (IO ResponseReceived -> IO (Either SomeException ResponseReceived))
    -> IO ResponseReceived
    -> IO (Either SomeException ResponseReceived)
    forall a b. (a -> b) -> a -> b
    $ Application
    app Request
    req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
    -> (Response -> IO ResponseReceived) -> IO ResponseReceived
    forall a b. (a -> b) -> a -> b
    $ \Response
    rsp -> do
            (Response
    h2rsp,Status
    st,Bool
    hasBody) <- Settings
    -> InternalInfo
    -> Request
    -> Response
    -> IO (Response, Status, Bool)
    fromResponse Settings
    settings InternalInfo
    ii Request
    req Response
    rsp
            [PushPromise]
    pps <- if Bool
    hasBody then InternalInfo -> Request -> IO [PushPromise]
    fromPushPromises InternalInfo
    ii Request
    req else [PushPromise] -> IO [PushPromise]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            IORef (Maybe (Response, [PushPromise], Status))
    -> Maybe (Response, [PushPromise], Status) -> IO ()
    forall a. IORef a -> a -> IO ()
    I.writeIORef IORef (Maybe (Response, [PushPromise], Status))
    ref (Maybe (Response, [PushPromise], Status) -> IO ())
    -> Maybe (Response, [PushPromise], Status) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (Response, [PushPromise], Status)
    -> Maybe (Response, [PushPromise], Status)
    forall a. a -> Maybe a
    Just (Response
    h2rsp, [PushPromise]
    pps, Status
    st)
            ()
    _ <- Response -> [PushPromise] -> IO ()
    response Response
    h2rsp [PushPromise]
    pps
            ResponseReceived -> IO ResponseReceived
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ResponseReceived
    ResponseReceived
        case Either SomeException ResponseReceived
    eResponseReceived of
          Right ResponseReceived
    ResponseReceived -> do
              Just (Response
    h2rsp, [PushPromise]
    pps, Status
    st) <- IORef (Maybe (Response, [PushPromise], Status))
    -> IO (Maybe (Response, [PushPromise], Status))
    forall a. IORef a -> IO a
    I.readIORef IORef (Maybe (Response, [PushPromise], Status))
    ref
              let msiz :: Maybe Integer
    msiz = Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Integer) -> Maybe Int -> Maybe Integer
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Response -> Maybe Int
    H2.responseBodySize Response
    h2rsp
              Request -> Status -> Maybe Integer -> IO ()
    logResponse Request
    req Status
    st Maybe Integer
    msiz
              (PushPromise -> IO ()) -> [PushPromise] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Request -> PushPromise -> IO ()
    logPushPromise Request
    req) [PushPromise]
    pps
          Left SomeException
    e -> do
                Settings -> Maybe Request -> SomeException -> IO ()
    S.settingsOnException Settings
    settings (Request -> Maybe Request
    forall a. a -> Maybe a
    Just Request
    req) SomeException
    e
                let ersp :: Response
    ersp = Settings -> SomeException -> Response
    S.settingsOnExceptionResponse Settings
    settings SomeException
    e
                    st :: Status
    st = Response -> Status
    responseStatus Response
    ersp
                (Response
    h2rsp',Status
    _,Bool
    _) <- Settings
    -> InternalInfo
    -> Request
    -> Response
    -> IO (Response, Status, Bool)
    fromResponse Settings
    settings InternalInfo
    ii Request
    req Response
    ersp
                let msiz :: Maybe Integer
    msiz = Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Integer) -> Maybe Int -> Maybe Integer
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Response -> Maybe Int
    H2.responseBodySize Response
    h2rsp'
                ()
    _ <- Response -> [PushPromise] -> IO ()
    response Response
    h2rsp' []
                Request -> Status -> Maybe Integer -> IO ()
    logResponse Request
    req Status
    st Maybe Integer
    msiz
        () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      where
        toWAIRequest :: Request -> Aux -> IO Request
    toWAIRequest Request
    h2req Aux
    aux = InternalInfo -> Settings -> SockAddr -> ToReq
    toRequest InternalInfo
    ii Settings
    settings SockAddr
    addr HeaderTable
    hdr Maybe Int
    bdylen Recv
    bdy Handle
    th Transport
    transport
          where
            !hdr :: HeaderTable
    hdr = Request -> HeaderTable
    H2.requestHeaders Request
    h2req
            !bdy :: Recv
    bdy = Request -> Recv
    H2.getRequestBodyChunk Request
    h2req
            !bdylen :: Maybe Int
    bdylen = Request -> Maybe Int
    H2.requestBodySize Request
    h2req
            !th :: Handle
    th = Aux -> Handle
    H2.auxTimeHandle Aux
    aux

        logResponse :: Request -> Status -> Maybe Integer -> IO ()
    logResponse = Settings -> Request -> Status -> Maybe Integer -> IO ()
    S.settingsLogger Settings
    settings

        logPushPromise :: Request -> PushPromise -> IO ()
    logPushPromise Request
    req PushPromise
    pp = Request -> ByteString -> Integer -> IO ()
    logger Request
    req ByteString
    path Integer
    siz
          where
            !logger :: Request -> ByteString -> Integer -> IO ()
    logger = Settings -> Request -> ByteString -> Integer -> IO ()
    S.settingsServerPushLogger Settings
    settings
            !path :: ByteString
    path = PushPromise -> ByteString
    H2.promiseRequestPath PushPromise
    pp
            !siz :: Integer
    siz = case Response -> Maybe Int
    H2.responseBodySize (Response -> Maybe Int) -> Response -> Maybe Int
    forall a b. (a -> b) -> a -> b
    $ PushPromise -> Response
    H2.promiseResponse PushPromise
    pp of
                Maybe Int
    Nothing -> Integer
    0
                Just Int
    s  -> Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    s

    wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
    wrappedRecvN :: Handle -> IORef Bool -> Int -> RecvN -> RecvN
    wrappedRecvN Handle
    th IORef Bool
    istatus Int
    slowlorisSize RecvN
    readN Int
    bufsize = do
        ByteString
    bs <-  (SomeException -> Recv) -> Recv -> Recv
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    (SomeException -> m a) -> m a -> m a
    UnliftIO.handleAny SomeException -> Recv
    handler (Recv -> Recv) -> Recv -> Recv
    forall a b. (a -> b) -> a -> b
    $ RecvN
    readN Int
    bufsize
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (ByteString -> Bool
    BS.null ByteString
    bs) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    istatus Bool
    True
        -- TODO: think about the slowloris protection in HTTP2: current code
        -- might open a slow-loris attack vector. Rather than timing we should
        -- consider limiting the per-client connections assuming that in HTTP2
        -- we should allow only few connections per host (real-world
        -- deployments with large NATs may be trickier).
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ByteString -> Int
    BS.length ByteString
    bs Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    slowlorisSize Bool -> Bool -> Bool
    || Int
    bufsize Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Handle -> IO ()
    T.tickle Handle
    th
        ByteString -> Recv
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    bs
     where
       handler :: UnliftIO.SomeException -> IO ByteString
       handler :: SomeException -> Recv
    handler SomeException
    _ = ByteString -> Recv
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    ""

    -- connClose must not be called here since Run:fork calls it
    goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
    goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
    goaway Connection{IO ()
    Recv
    IORef Bool
    IORef WriteBuffer
    SockAddr
    [ByteString] -> IO ()
    RecvBuf
    ByteString -> IO ()
    SendFile
    connRecv :: Connection -> Recv
    connWriteBuffer :: Connection -> IORef WriteBuffer
    connSendAll :: Connection -> ByteString -> IO ()
    connMySockAddr :: Connection -> SockAddr
    connSendMany :: [ByteString] -> IO ()
    connSendAll :: ByteString -> IO ()
    connSendFile :: SendFile
    connClose :: IO ()
    connRecv :: Recv
    connRecvBuf :: RecvBuf
    connWriteBuffer :: IORef WriteBuffer
    connHTTP2 :: IORef Bool
    connMySockAddr :: SockAddr
    connSendMany :: Connection -> [ByteString] -> IO ()
    connSendFile :: Connection -> SendFile
    connClose :: Connection -> IO ()
    connRecvBuf :: Connection -> RecvBuf
    connHTTP2 :: Connection -> IORef Bool
    ..} ErrorCodeId
    etype ByteString
    debugmsg = ByteString -> IO ()
    connSendAll ByteString
    bytestream
      where
        einfo :: EncodeInfo
    einfo = (FrameFlags -> FrameFlags) -> Int -> EncodeInfo
    H2.encodeInfo FrameFlags -> FrameFlags
    forall a. a -> a
    id Int
    0
        frame :: FramePayload
    frame = Int -> ErrorCodeId -> ByteString -> FramePayload
    H2.GoAwayFrame Int
    0 ErrorCodeId
    etype ByteString
    debugmsg
        bytestream :: ByteString
    bytestream = EncodeInfo -> FramePayload -> ByteString
    H2.encodeFrame EncodeInfo
    einfo FramePayload
    frame