    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP #-}

    module Network.Wai.Handler.Warp.HTTP2.Request (
        toRequest,
        getHTTP2Data,
        setHTTP2Data,
        modifyHTTP2Data,
    ) where

    import Control.Arrow (first)
    import qualified Data.ByteString.Char8 as C8
    import Data.IORef
    import qualified Data.Vault.Lazy as Vault
    import Network.HPACK
    import Network.HPACK.Token
    import qualified Network.HTTP.Types as H
    import Network.Socket (SockAddr)
    import Network.Wai
    import System.IO.Unsafe (unsafePerformIO)
    import qualified System.TimeManager as T

    import Network.Wai.Handler.Warp.HTTP2.Types
    import Network.Wai.Handler.Warp.Imports
    import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey)
    #ifdef MIN_VERSION_crypton_x509
    import Network.Wai.Handler.Warp.Request (getClientCertificateKey)
    #endif
    import qualified Network.Wai.Handler.Warp.Settings as S (
        Settings,
        settingsNoParsePath,
     )
    import Network.Wai.Handler.Warp.Types

    type ToReq =
        (TokenHeaderList, ValueTable)
        -> Maybe Int
        -> IO ByteString
        -> T.Handle
        -> Transport
        -> IO Request

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

    http30 :: H.HttpVersion
    http30 :: HttpVersion
    http30 = Int -> Int -> HttpVersion
    H.HttpVersion Int
    3 Int
    0

    toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq
    toRequest :: InternalInfo -> Settings -> SockAddr -> ToReq
    toRequest InternalInfo
    ii Settings
    settings SockAddr
    addr (TokenHeaderList, ValueTable)
    ht Maybe Int
    bodylen IO ByteString
    body Handle
    th Transport
    transport = do
        ref <- Maybe HTTP2Data -> IO (IORef (Maybe HTTP2Data))
    forall a. a -> IO (IORef a)
    newIORef Maybe HTTP2Data
    forall a. Maybe a
    Nothing
        toRequest' ii settings addr ref ht bodylen body th transport

    toRequest'
        :: InternalInfo
        -> S.Settings
        -> SockAddr
        -> IORef (Maybe HTTP2Data)
        -> ToReq
    toRequest' :: InternalInfo
    -> Settings -> SockAddr -> IORef (Maybe HTTP2Data) -> ToReq
    toRequest' InternalInfo
    ii Settings
    settings SockAddr
    addr IORef (Maybe HTTP2Data)
    ref (TokenHeaderList
    reqths, ValueTable
    reqvt) Maybe Int
    bodylen IO ByteString
    body Handle
    th Transport
    transport =
        -- setting 'requestBody' with 'setRequestBodyChunks' to  avoid warnings
        Request -> IO Request
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Request -> IO Request) -> Request -> IO Request
    forall a b. (a -> b) -> a -> b
    $! IO ByteString -> Request -> Request
    setRequestBodyChunks IO ByteString
    body Request
    req
      where
        !req :: Request
    req =
            Request
    defaultRequest
                { requestMethod = colonMethod
                , httpVersion = if isTransportQUIC transport then http30 else H.http20
                , rawPathInfo = rawPath
                , pathInfo = H.decodePathSegments path
                , rawQueryString = query
                , queryString = H.parseQuery query
                , requestHeaders = headers
                , isSecure = isTransportSecure transport
                , remoteHost = addr
                , vault = vaultValue
                , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen
                , requestHeaderHost = mHost <|> mAuth
                , requestHeaderRange = mRange
                , requestHeaderReferer = mReferer
                , requestHeaderUserAgent = mUserAgent
                }
        headers :: [(HeaderName, ByteString)]
    headers = (TokenHeader -> (HeaderName, ByteString))
    -> TokenHeaderList -> [(HeaderName, ByteString)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Token -> HeaderName) -> TokenHeader -> (HeaderName, ByteString)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first Token -> HeaderName
    tokenKey) TokenHeaderList
    ths
          where
            ths :: TokenHeaderList
    ths = case Maybe ByteString
    mHost of
                Just ByteString
    _ -> TokenHeaderList
    reqths
                Maybe ByteString
    Nothing -> case Maybe ByteString
    mAuth of
                    Just ByteString
    auth -> (Token
    tokenHost, ByteString
    auth) TokenHeader -> TokenHeaderList -> TokenHeaderList
    forall a. a -> [a] -> [a]
    : TokenHeaderList
    reqths
                    Maybe ByteString
    _ -> TokenHeaderList
    reqths
        !mPath :: Maybe ByteString
    mPath = Token -> ValueTable -> Maybe ByteString
    getHeaderValue Token
    tokenPath ValueTable
    reqvt -- SHOULD
        !colonMethod :: ByteString
    colonMethod = Maybe ByteString -> ByteString
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Token -> ValueTable -> Maybe ByteString
    getHeaderValue Token
    tokenMethod ValueTable
    reqvt -- MUST
        !mAuth :: Maybe ByteString
    mAuth = Token -> ValueTable -> Maybe ByteString
    getHeaderValue Token
    tokenAuthority ValueTable
    reqvt -- SHOULD
        !mHost :: Maybe ByteString
    mHost = Token -> ValueTable -> Maybe ByteString
    getHeaderValue Token
    tokenHost ValueTable
    reqvt
        !mRange :: Maybe ByteString
    mRange = Token -> ValueTable -> Maybe ByteString
    getHeaderValue Token
    tokenRange ValueTable
    reqvt
        !mReferer :: Maybe ByteString
    mReferer = Token -> ValueTable -> Maybe ByteString
    getHeaderValue Token
    tokenReferer ValueTable
    reqvt
        !mUserAgent :: Maybe ByteString
    mUserAgent = Token -> ValueTable -> Maybe ByteString
    getHeaderValue Token
    tokenUserAgent ValueTable
    reqvt
        -- CONNECT request will have ":path" omitted, use ":authority" as unparsed
        -- path instead so that it will have consistent behavior compare to HTTP 1.0
        (ByteString
    unparsedPath, ByteString
    query) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
    C8.break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '?') (ByteString -> (ByteString, ByteString))
    -> ByteString -> (ByteString, ByteString)
    forall a b. (a -> b) -> a -> b
    $ Maybe ByteString -> ByteString
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe ByteString
    mPath Maybe ByteString -> Maybe ByteString -> Maybe ByteString
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Maybe ByteString
    mAuth)
        !path :: ByteString
    path = ByteString -> ByteString
    H.extractPath ByteString
    unparsedPath
        !rawPath :: ByteString
    rawPath = if Settings -> Bool
    S.settingsNoParsePath Settings
    settings then ByteString
    unparsedPath else ByteString
    path
        -- fixme: pauseTimeout. th is not available here.
        !vaultValue :: Vault
    vaultValue =
            Key (FilePath -> IO FileInfo)
    -> (FilePath -> IO FileInfo) -> Vault -> Vault
    forall a. Key a -> a -> Vault -> Vault
    Vault.insert Key (FilePath -> IO FileInfo)
    getFileInfoKey (InternalInfo -> FilePath -> IO FileInfo
    getFileInfo InternalInfo
    ii)
                (Vault -> Vault) -> (Vault -> Vault) -> Vault -> Vault
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Key (IO (Maybe HTTP2Data))
    -> IO (Maybe HTTP2Data) -> Vault -> Vault
    forall a. Key a -> a -> Vault -> Vault
    Vault.insert Key (IO (Maybe HTTP2Data))
    getHTTP2DataKey (IORef (Maybe HTTP2Data) -> IO (Maybe HTTP2Data)
    forall a. IORef a -> IO a
    readIORef IORef (Maybe HTTP2Data)
    ref)
                (Vault -> Vault) -> (Vault -> Vault) -> Vault -> Vault
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Key (Maybe HTTP2Data -> IO ())
    -> (Maybe HTTP2Data -> IO ()) -> Vault -> Vault
    forall a. Key a -> a -> Vault -> Vault
    Vault.insert Key (Maybe HTTP2Data -> IO ())
    setHTTP2DataKey (IORef (Maybe HTTP2Data) -> Maybe HTTP2Data -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef (Maybe HTTP2Data)
    ref)
                (Vault -> Vault) -> (Vault -> Vault) -> Vault -> Vault
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    -> ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    -> Vault
    -> Vault
    forall a. Key a -> a -> Vault -> Vault
    Vault.insert Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    modifyHTTP2DataKey (IORef (Maybe HTTP2Data)
    -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()
    forall a. IORef a -> (a -> a) -> IO ()
    modifyIORef' IORef (Maybe HTTP2Data)
    ref)
                (Vault -> Vault) -> (Vault -> Vault) -> Vault -> Vault
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Key (IO ()) -> IO () -> Vault -> Vault
    forall a. Key a -> a -> Vault -> Vault
    Vault.insert Key (IO ())
    pauseTimeoutKey (Handle -> IO ()
    T.pause Handle
    th)
    #ifdef MIN_VERSION_crypton_x509
                (Vault -> Vault) -> (Vault -> Vault) -> Vault -> Vault
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Key (Maybe CertificateChain)
    -> Maybe CertificateChain -> Vault -> Vault
    forall a. Key a -> a -> Vault -> Vault
    Vault.insert Key (Maybe CertificateChain)
    getClientCertificateKey (Transport -> Maybe CertificateChain
    getTransportClientCertificate Transport
    transport)
    #endif
                (Vault -> Vault) -> Vault -> Vault
    forall a b. (a -> b) -> a -> b
    $ Vault
    Vault.empty

    getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))
    getHTTP2DataKey :: Key (IO (Maybe HTTP2Data))
    getHTTP2DataKey = IO (Key (IO (Maybe HTTP2Data))) -> Key (IO (Maybe HTTP2Data))
    forall a. IO a -> a
    unsafePerformIO IO (Key (IO (Maybe HTTP2Data)))
    forall a. IO (Key a)
    Vault.newKey
    {-# NOINLINE getHTTP2DataKey #-}

    -- | Getting 'HTTP2Data' through vault of the request.
    --   Warp uses this to receive 'HTTP2Data' from 'Middleware'.
    --
    --   Since: 3.2.7
    getHTTP2Data :: Request -> IO (Maybe HTTP2Data)
    getHTTP2Data :: Request -> IO (Maybe HTTP2Data)
    getHTTP2Data Request
    req = case Key (IO (Maybe HTTP2Data)) -> Vault -> Maybe (IO (Maybe HTTP2Data))
    forall a. Key a -> Vault -> Maybe a
    Vault.lookup Key (IO (Maybe HTTP2Data))
    getHTTP2DataKey (Request -> Vault
    vault Request
    req) of
        Maybe (IO (Maybe HTTP2Data))
    Nothing -> Maybe HTTP2Data -> IO (Maybe HTTP2Data)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe HTTP2Data
    forall a. Maybe a
    Nothing
        Just IO (Maybe HTTP2Data)
    getter -> IO (Maybe HTTP2Data)
    getter

    setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())
    setHTTP2DataKey :: Key (Maybe HTTP2Data -> IO ())
    setHTTP2DataKey = IO (Key (Maybe HTTP2Data -> IO ()))
    -> Key (Maybe HTTP2Data -> IO ())
    forall a. IO a -> a
    unsafePerformIO IO (Key (Maybe HTTP2Data -> IO ()))
    forall a. IO (Key a)
    Vault.newKey
    {-# NOINLINE setHTTP2DataKey #-}

    -- | Setting 'HTTP2Data' through vault of the request.
    --   'Application' or 'Middleware' should use this.
    --
    --   Since: 3.2.7
    setHTTP2Data :: Request -> Maybe HTTP2Data -> IO ()
    setHTTP2Data :: Request -> Maybe HTTP2Data -> IO ()
    setHTTP2Data Request
    req Maybe HTTP2Data
    mh2d = case Key (Maybe HTTP2Data -> IO ())
    -> Vault -> Maybe (Maybe HTTP2Data -> IO ())
    forall a. Key a -> Vault -> Maybe a
    Vault.lookup Key (Maybe HTTP2Data -> IO ())
    setHTTP2DataKey (Request -> Vault
    vault Request
    req) of
        Maybe (Maybe HTTP2Data -> IO ())
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        Just Maybe HTTP2Data -> IO ()
    setter -> Maybe HTTP2Data -> IO ()
    setter Maybe HTTP2Data
    mh2d

    modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    modifyHTTP2DataKey :: Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    modifyHTTP2DataKey = IO (Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()))
    -> Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    forall a. IO a -> a
    unsafePerformIO IO (Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()))
    forall a. IO (Key a)
    Vault.newKey
    {-# NOINLINE modifyHTTP2DataKey #-}

    -- | Modifying 'HTTP2Data' through vault of the request.
    --   'Application' or 'Middleware' should use this.
    --
    --   Since: 3.2.8
    modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()
    modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()
    modifyHTTP2Data Request
    req Maybe HTTP2Data -> Maybe HTTP2Data
    func = case Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    -> Vault -> Maybe ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    forall a. Key a -> Vault -> Maybe a
    Vault.lookup Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    modifyHTTP2DataKey (Request -> Vault
    vault Request
    req) of
        Maybe ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        Just (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()
    modify -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()
    modify Maybe HTTP2Data -> Maybe HTTP2Data
    func