{-# 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
    IORef (Maybe HTTP2Data)
ref <- Maybe HTTP2Data -> IO (IORef (Maybe HTTP2Data))
forall a. a -> IO (IORef a)
newIORef Maybe HTTP2Data
forall a. Maybe a
Nothing
    InternalInfo
-> Settings -> SockAddr -> IORef (Maybe HTTP2Data) -> ToReq
toRequest' InternalInfo
ii Settings
settings SockAddr
addr IORef (Maybe HTTP2Data)
ref (TokenHeaderList, ValueTable)
ht Maybe Int
bodylen IO ByteString
body Handle
th Transport
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 :: [(CI ByteString, ByteString)]
headers = (TokenHeader -> (CI ByteString, ByteString))
-> TokenHeaderList -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Token -> CI ByteString)
-> TokenHeader -> (CI ByteString, 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 -> CI ByteString
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