{-# LANGUAGE BangPatterns #-}

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 Network.Wai.Internal (Request(..))
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, getClientCertificateKey)
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 = Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
  where
    !req :: Request
req = Request :: ByteString
-> HttpVersion
-> ByteString
-> ByteString
-> RequestHeaders
-> Bool
-> SockAddr
-> [Text]
-> Query
-> IO ByteString
-> Vault
-> RequestBodyLength
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Request
Request {
        requestMethod :: ByteString
requestMethod = ByteString
colonMethod
      , httpVersion :: HttpVersion
httpVersion = if Transport -> Bool
isTransportQUIC Transport
transport then HttpVersion
http30 else HttpVersion
H.http20
      , rawPathInfo :: ByteString
rawPathInfo = ByteString
rawPath
      , pathInfo :: [Text]
pathInfo = ByteString -> [Text]
H.decodePathSegments ByteString
path
      , rawQueryString :: ByteString
rawQueryString = ByteString
query
      , queryString :: Query
queryString = ByteString -> Query
H.parseQuery ByteString
query
      , requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
headers
      , isSecure :: Bool
isSecure = Transport -> Bool
isTransportSecure Transport
transport
      , remoteHost :: SockAddr
remoteHost = SockAddr
addr
      , requestBody :: IO ByteString
requestBody = IO ByteString
body
      , vault :: Vault
vault = Vault
vaultValue
      , requestBodyLength :: RequestBodyLength
requestBodyLength = RequestBodyLength
-> (Int -> RequestBodyLength) -> Maybe Int -> RequestBodyLength
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RequestBodyLength
ChunkedBody (Word64 -> RequestBodyLength
KnownLength (Word64 -> RequestBodyLength)
-> (Int -> Word64) -> Int -> RequestBodyLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Int
bodylen
      , requestHeaderHost :: Maybe ByteString
requestHeaderHost      = Maybe ByteString
mHost Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ByteString
mAuth
      , requestHeaderRange :: Maybe ByteString
requestHeaderRange     = Maybe ByteString
mRange
      , requestHeaderReferer :: Maybe ByteString
requestHeaderReferer   = Maybe ByteString
mReferer
      , requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent = Maybe ByteString
mUserAgent
      }
    headers :: RequestHeaders
headers = (TokenHeader -> (CI ByteString, ByteString))
-> TokenHeaderList -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map ((Token -> CI ByteString)
-> TokenHeader -> (CI ByteString, ByteString)
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 (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
forall a b. (a -> b) -> a -> b
$ 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
forall a b. (a -> b) -> a -> b
$ 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
forall a b. (a -> b) -> a -> b
$ 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
forall a b. (a -> b) -> a -> b
$ Key (IO ()) -> IO () -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (IO ())
pauseTimeoutKey (Handle -> IO ()
T.pause Handle
th)
                (Vault -> Vault) -> Vault -> Vault
forall a b. (a -> b) -> a -> b
$ 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)
                  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 (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 (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 (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