{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Network.Wai.Handler.Warp.Request (
    FirstRequest(..),
    recvRequest,
    headerLines,
    pauseTimeoutKey,
    getFileInfoKey,
#ifdef MIN_VERSION_crypton_x509
    getClientCertificateKey,
#endif
    NoKeepAliveRequest (..),
) where

import qualified Control.Concurrent as Conc (yield)
import qualified Data.ByteString as S
import qualified Data.ByteString.Unsafe as SU
import qualified Data.CaseInsensitive as CI
import qualified Data.IORef as I
import qualified Data.Vault.Lazy as Vault
import Data.Word8 (_0, _comma, _cr, _lf, _space, _tab, isDigit)
#ifdef MIN_VERSION_crypton_x509
import Data.X509
#endif
import Control.Exception (Exception, throwIO)
import qualified Network.HTTP.Types as H
import Network.Socket (SockAddr)
import Network.Wai
import Network.Wai.Handler.Warp.Types
import Network.Wai.Internal
import System.IO.Unsafe (unsafePerformIO)
import qualified System.TimeManager as Timeout
import Prelude hiding (lines)

import Network.Wai.Handler.Warp.Conduit
import Network.Wai.Handler.Warp.FileInfoCache
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.Imports hiding (readInt)
import Network.Wai.Handler.Warp.RequestHeader
import Network.Wai.Handler.Warp.Settings (
    Settings,
    settingsMaxTotalHeaderLength,
    settingsNoParsePath,
 )

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

-- | first request on this connection?
data FirstRequest = FirstRequest | SubsequentRequest

-- | Receiving a HTTP request from 'Connection' and parsing its header
--   to create 'Request'.
recvRequest
    :: FirstRequest
    -> Settings
    -> Connection
    -> InternalInfo
    -> Timeout.Handle
    -> SockAddr
    -- ^ Peer's address.
    -> Source
    -- ^ Where HTTP request comes from.
    -> Transport
    -> IO
        ( Request
        , Maybe (I.IORef Int)
        , IndexedRequestHeader
        , IO ByteString
        )
    -- ^
    -- 'Request' passed to 'Application',
    -- how many bytes remain to be consumed, if known
    -- 'IndexedHeader' of HTTP request for internal use,
    -- Body producing action used for flushing the request body
recvRequest :: FirstRequest
-> Settings
-> Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Source
-> Transport
-> IO
     (Request, Maybe (IORef Int), IndexedRequestHeader, IO ByteString)
recvRequest FirstRequest
firstRequest Settings
settings Connection
conn InternalInfo
ii Handle
th SockAddr
addr Source
src Transport
transport = do
    [ByteString]
hdrlines <- Int -> FirstRequest -> Source -> IO [ByteString]
headerLines (Settings -> Int
settingsMaxTotalHeaderLength Settings
settings) FirstRequest
firstRequest Source
src
    (ByteString
method, ByteString
unparsedPath, ByteString
path, ByteString
query, HttpVersion
httpversion, RequestHeaders
hdr) <-
        [ByteString]
-> IO
     (ByteString, ByteString, ByteString, ByteString, HttpVersion,
      RequestHeaders)
parseHeaderLines [ByteString]
hdrlines
    let idxhdr :: IndexedRequestHeader
idxhdr = RequestHeaders -> IndexedRequestHeader
indexRequestHeader RequestHeaders
hdr
        expect :: Maybe ByteString
expect = IndexedRequestHeader -> Maybe ByteString
reqidxExpect IndexedRequestHeader
idxhdr
        handle100Continue :: IO ()
handle100Continue = Connection -> HttpVersion -> Maybe ByteString -> IO ()
handleExpect Connection
conn HttpVersion
httpversion Maybe ByteString
expect
    HttpVersion -> IndexedRequestHeader -> IO ()
checkHost HttpVersion
httpversion IndexedRequestHeader
idxhdr
    (IO ByteString
rbody, Maybe (IORef Int)
remainingRef, RequestBodyLength
bodyLength) <- Source
-> IndexedRequestHeader
-> IO (IO ByteString, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src IndexedRequestHeader
idxhdr
    -- body producing function which will produce '100-continue', if needed
    IO ByteString
rbody' <- Maybe (IORef Int)
-> Handle -> IO ByteString -> IO () -> IO (IO ByteString)
timeoutBody Maybe (IORef Int)
remainingRef Handle
th IO ByteString
rbody IO ()
handle100Continue
    -- body producing function which will never produce 100-continue
    IO ByteString
rbodyFlush <- Maybe (IORef Int)
-> Handle -> IO ByteString -> IO () -> IO (IO ByteString)
timeoutBody Maybe (IORef Int)
remainingRef Handle
th IO ByteString
rbody (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    let rawPath :: ByteString
rawPath = if Settings -> Bool
settingsNoParsePath Settings
settings then ByteString
unparsedPath else ByteString
path
        -- Lazy on purpose (~ defeats -XStrict): most handlers never touch
        -- 'vault', so don't pay for the inserts unless somebody looks.
        ~Vault
vaultValue =
            Key (IO ()) -> IO () -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (IO ())
pauseTimeoutKey (Handle -> IO ()
Timeout.pause Handle
th)
                (Vault -> Vault) -> (Vault -> Vault) -> Vault -> Vault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
#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
        req :: Request
req =
            Request
                { requestMethod :: ByteString
requestMethod = ByteString
method
                , httpVersion :: HttpVersion
httpVersion = HttpVersion
httpversion
                , pathInfo :: [Text]
pathInfo = ByteString -> [Text]
H.decodePathSegments ByteString
path
                , rawPathInfo :: ByteString
rawPathInfo = ByteString
rawPath
                , rawQueryString :: ByteString
rawQueryString = ByteString
query
                , queryString :: Query
queryString = ByteString -> Query
H.parseQuery ByteString
query
                , requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
hdr
                , isSecure :: Bool
isSecure = Transport -> Bool
isTransportSecure Transport
transport
                , remoteHost :: SockAddr
remoteHost = SockAddr
addr
                , requestBody :: IO ByteString
requestBody = IO ByteString
rbody'
                , vault :: Vault
vault = Vault
vaultValue
                , requestBodyLength :: RequestBodyLength
requestBodyLength = RequestBodyLength
bodyLength
                , requestHeaderHost :: Maybe ByteString
requestHeaderHost = IndexedRequestHeader -> Maybe ByteString
reqidxHost IndexedRequestHeader
idxhdr
                , requestHeaderRange :: Maybe ByteString
requestHeaderRange = IndexedRequestHeader -> Maybe ByteString
reqidxRange IndexedRequestHeader
idxhdr
                , requestHeaderReferer :: Maybe ByteString
requestHeaderReferer = IndexedRequestHeader -> Maybe ByteString
reqidxReferer IndexedRequestHeader
idxhdr
                , requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent = IndexedRequestHeader -> Maybe ByteString
reqidxUserAgent IndexedRequestHeader
idxhdr
                , requestSendEarlyHints :: RequestHeaders -> IO ()
requestSendEarlyHints = \RequestHeaders
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                }
    (Request, Maybe (IORef Int), IndexedRequestHeader, IO ByteString)
-> IO
     (Request, Maybe (IORef Int), IndexedRequestHeader, IO ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, Maybe (IORef Int)
remainingRef, IndexedRequestHeader
idxhdr, IO ByteString
rbodyFlush)

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

headerLines :: Int -> FirstRequest -> Source -> IO [ByteString]
headerLines :: Int -> FirstRequest -> Source -> IO [ByteString]
headerLines Int
maxTotalHeaderLength FirstRequest
firstRequest Source
src = do
    ByteString
bs <- Source -> IO ByteString
readSource Source
src
    if ByteString -> Bool
S.null ByteString
bs
        then -- When we're working on a keep-alive connection and trying to
        -- get the second or later request, we don't want to treat the
        -- lack of data as a real exception. See the http1 function in
        -- the Run module for more details.

            case FirstRequest
firstRequest of
              FirstRequest
FirstRequest -> InvalidRequest -> IO [ByteString]
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
ConnectionClosedByPeer
              FirstRequest
SubsequentRequest -> NoKeepAliveRequest -> IO [ByteString]
forall e a. Exception e => e -> IO a
throwIO NoKeepAliveRequest
NoKeepAliveRequest
        else Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src (Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
0 Int
0 BSEndoList
forall a. a -> a
id BSEndo
forall a. a -> a
id) ByteString
bs

data NoKeepAliveRequest = NoKeepAliveRequest
    deriving (Int -> NoKeepAliveRequest -> ShowS
[NoKeepAliveRequest] -> ShowS
NoKeepAliveRequest -> FilePath
(Int -> NoKeepAliveRequest -> ShowS)
-> (NoKeepAliveRequest -> FilePath)
-> ([NoKeepAliveRequest] -> ShowS)
-> Show NoKeepAliveRequest
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoKeepAliveRequest -> ShowS
showsPrec :: Int -> NoKeepAliveRequest -> ShowS
$cshow :: NoKeepAliveRequest -> FilePath
show :: NoKeepAliveRequest -> FilePath
$cshowList :: [NoKeepAliveRequest] -> ShowS
showList :: [NoKeepAliveRequest] -> ShowS
Show)
instance Exception NoKeepAliveRequest

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

-- | Refusing a request whose @Host@ RFC 9112 section 3.2 refuses.
--
-- A proxy routes on the first @Host@ and an application reads
-- 'requestHeaderHost', the last of them: a repeated one is a way to
-- reach a virtual host the proxy would not have routed to.
checkHost :: H.HttpVersion -> IndexedRequestHeader -> IO ()
checkHost :: HttpVersion -> IndexedRequestHeader -> IO ()
checkHost HttpVersion
httpversion IndexedRequestHeader
idxhdr
    | IndexedRequestHeader -> Bool
reqidxHostRepeated IndexedRequestHeader
idxhdr = InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
BadHost
    | HttpVersion
httpversion HttpVersion -> HttpVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= HttpVersion
H.http11, Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing (IndexedRequestHeader -> Maybe ByteString
reqidxHost IndexedRequestHeader
idxhdr) = InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
BadHost
    | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

handleExpect
    :: Connection
    -> H.HttpVersion
    -> Maybe HeaderValue
    -> IO ()
handleExpect :: Connection -> HttpVersion -> Maybe ByteString -> IO ()
handleExpect Connection
conn HttpVersion
ver (Just ByteString
"100-continue") = do
    Connection -> ByteString -> IO ()
connSendAll Connection
conn ByteString
continue
    IO ()
Conc.yield
  where
    continue :: ByteString
continue
        | HttpVersion
ver HttpVersion -> HttpVersion -> Bool
forall a. Eq a => a -> a -> Bool
== HttpVersion
H.http11 = ByteString
"HTTP/1.1 100 Continue\r\n\r\n"
        | Bool
otherwise = ByteString
"HTTP/1.0 100 Continue\r\n\r\n"
handleExpect Connection
_ HttpVersion
_ Maybe ByteString
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

bodyAndSource
    :: Source
    -> IndexedRequestHeader
    -> IO
        ( IO ByteString
        , Maybe (I.IORef Int)
        , RequestBodyLength
        )
bodyAndSource :: Source
-> IndexedRequestHeader
-> IO (IO ByteString, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src IndexedRequestHeader
idxhdr = do
    BodyFraming
framing <- IndexedRequestHeader -> IO BodyFraming
bodyFraming IndexedRequestHeader
idxhdr
    case BodyFraming
framing of
        BodyFraming
FramedByChunks -> do
            CSource
csrc <- Source -> IO CSource
mkCSource Source
src
            (IO ByteString, Maybe (IORef Int), RequestBodyLength)
-> IO (IO ByteString, Maybe (IORef Int), RequestBodyLength)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CSource -> IO ByteString
readCSource CSource
csrc, Maybe (IORef Int)
forall a. Maybe a
Nothing, RequestBodyLength
ChunkedBody)
        FramedByLength Int
len -> do
            isrc :: ISource
isrc@(ISource Source
_ IORef Int
remaining) <- Source -> Int -> IO ISource
mkISource Source
src Int
len
            (IO ByteString, Maybe (IORef Int), RequestBodyLength)
-> IO (IO ByteString, Maybe (IORef Int), RequestBodyLength)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ISource -> IO ByteString
readISource ISource
isrc, IORef Int -> Maybe (IORef Int)
forall a. a -> Maybe a
Just IORef Int
remaining, Word64 -> RequestBodyLength
KnownLength (Word64 -> RequestBodyLength) -> Word64 -> RequestBodyLength
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

-- | How the end of the request body is found (RFC 9112, section 6).
data BodyFraming
    = FramedByChunks
    | FramedByLength Int

-- | Deciding how the request body is framed, or refusing the request.
--
-- Anything other than one framing this server and every intermediary
-- agree on is refused rather than read some way of warp's own: whoever
-- reads it the other way sees one request where warp sees two, which is
-- how a request is smuggled past a proxy.
bodyFraming :: IndexedRequestHeader -> IO BodyFraming
bodyFraming :: IndexedRequestHeader -> IO BodyFraming
bodyFraming IndexedRequestHeader
idxhdr = case IndexedRequestHeader -> Maybe ByteString
reqidxTransferEncoding IndexedRequestHeader
idxhdr of
    Maybe ByteString
Nothing -> Int -> BodyFraming
FramedByLength (Int -> BodyFraming) -> IO Int -> IO BodyFraming
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString -> IO Int
contentLength (IndexedRequestHeader -> Maybe ByteString
reqidxContentLength IndexedRequestHeader
idxhdr)
    -- Transfer-Encoding wins over Content-Length, so sending both is a
    -- way of showing each reader the framing it prefers. Take neither.
    Just ByteString
_ | Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (IndexedRequestHeader -> Maybe ByteString
reqidxContentLength IndexedRequestHeader
idxhdr) -> InvalidRequest -> IO BodyFraming
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
AmbiguousBodyLength
    Just ByteString
te -> case BSEndoList
forall a. [a] -> [a]
reverse BSEndoList -> BSEndoList
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
codings ByteString
te of
        -- The only coding warp implements, and the only one it can be
        -- sure an intermediary passed on undisturbed.
        [ByteString
"chunked"] -> BodyFraming -> IO BodyFraming
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BodyFraming
FramedByChunks
        -- Chunked frames the body, but warp decodes no coding under it.
        ByteString
"chunked" : [ByteString]
_ -> InvalidRequest -> IO BodyFraming
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
UnsupportedTransferEncoding
        -- Without chunked last, the length cannot be determined at all.
        [ByteString]
_ -> InvalidRequest -> IO BodyFraming
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
AmbiguousBodyLength
  where
    -- A comma separated list, each element allowed its own surrounding
    -- whitespace. RFC 9110 has a recipient ignore empty elements, so
    -- "chunked", " chunked" and "chunked," are each the one coding.
    codings :: ByteString -> [ByteString]
codings =
        (ByteString -> Bool) -> BSEndoList
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
S.null) BSEndoList
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BSEndo -> BSEndoList
forall a b. (a -> b) -> [a] -> [b]
map (BSEndo
forall s. FoldCase s => s -> s
CI.foldCase BSEndo -> BSEndo -> BSEndo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BSEndo
stripOWS) BSEndoList
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
_comma

-- | The length a Content-Length gives, or no body when there is none.
--
-- RFC 9112 asks for a value of nothing but digits, and for repeated
-- Content-Lengths to be refused unless every one of them says the same
-- thing. Warp used to read the leading digits and take 0 for the rest,
-- so "abc", a value too large for an 'Int', and a second Content-Length
-- hiding the first all became a request with no body at all -- and the
-- bytes that were the body became the next request on the connection.
contentLength :: Maybe HeaderValue -> IO Int
contentLength :: Maybe ByteString -> IO Int
contentLength Maybe ByteString
Nothing = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
contentLength (Just ByteString
bs) = case (ByteString -> Maybe Int) -> [ByteString] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Maybe Int
forall {a}. (Integral a, Bounded a) => ByteString -> Maybe a
readLength (ByteString -> Maybe Int) -> BSEndo -> ByteString -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BSEndo
stripOWS) ([ByteString] -> [Maybe Int]) -> [ByteString] -> [Maybe Int]
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> [ByteString]
S.split Word8
_comma ByteString
bs of
    Just Int
len : [Maybe Int]
lens | (Maybe Int -> Bool) -> [Maybe Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
len) [Maybe Int]
lens -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
len
    [Maybe Int]
_ -> InvalidRequest -> IO Int
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
AmbiguousBodyLength
  where
    readLength :: ByteString -> Maybe a
readLength ByteString
v
        | ByteString -> Bool
S.null ByteString
v Bool -> Bool -> Bool
|| Bool -> Bool
not ((Word8 -> Bool) -> ByteString -> Bool
S.all Word8 -> Bool
isDigit ByteString
v) = Maybe a
forall a. Maybe a
Nothing
        | Bool
otherwise = (Maybe a -> Word8 -> Maybe a) -> Maybe a -> ByteString -> Maybe a
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S.foldl' Maybe a -> Word8 -> Maybe a
forall {a}. (Integral a, Bounded a) => Maybe a -> Word8 -> Maybe a
accumulate (a -> Maybe a
forall a. a -> Maybe a
Just a
0) ByteString
v
    accumulate :: Maybe a -> Word8 -> Maybe a
accumulate Maybe a
Nothing Word8
_ = Maybe a
forall a. Maybe a
Nothing
    accumulate (Just a
n) Word8
w
        -- A length warp cannot hold is a length warp cannot enforce.
        | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> (a
forall a. Bounded a => a
maxBound a -> a -> a
forall a. Num a => a -> a -> a
- a
d) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
10 = Maybe a
forall a. Maybe a
Nothing
        | Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$! a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ a
d
      where
        d :: a
d = Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
_0)

-- | Optional whitespace, which RFC 9112 allows around the elements of a
--   list and gives no meaning to.
stripOWS :: ByteString -> ByteString
stripOWS :: BSEndo
stripOWS = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString)) -> BSEndo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd Word8 -> Bool
isOWS (ByteString -> (ByteString, ByteString))
-> BSEndo -> ByteString -> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> BSEndo
S.dropWhile Word8 -> Bool
isOWS

isOWS :: Word8 -> Bool
isOWS :: Word8 -> Bool
isOWS Word8
w = Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_tab

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

timeoutBody
    :: Maybe (I.IORef Int)
    -- ^ remaining
    -> Timeout.Handle
    -> IO ByteString
    -> IO ()
    -> IO (IO ByteString)
timeoutBody :: Maybe (IORef Int)
-> Handle -> IO ByteString -> IO () -> IO (IO ByteString)
timeoutBody Maybe (IORef Int)
remainingRef Handle
timeoutHandle IO ByteString
rbody IO ()
handle100Continue = do
    IORef Bool
isFirstRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
I.newIORef Bool
True

    let checkEmpty :: ByteString -> IO Bool
checkEmpty =
            case Maybe (IORef Int)
remainingRef of
                Maybe (IORef Int)
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (ByteString -> Bool) -> ByteString -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
S.null
                Just IORef Int
ref -> \ByteString
bs ->
                    if ByteString -> Bool
S.null ByteString
bs
                        then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                        else do
                            Int
x <- IORef Int -> IO Int
forall a. IORef a -> IO a
I.readIORef IORef Int
ref
                            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0

    IO ByteString -> IO (IO ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ByteString -> IO (IO ByteString))
-> IO ByteString -> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$ do
        Bool
isFirst <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
I.readIORef IORef Bool
isFirstRef

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isFirst (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            -- Only check if we need to produce the 100 Continue status
            -- when asking for the first chunk of the body
            IO ()
handle100Continue
            -- Timeout handling was paused after receiving the full request
            -- headers. Now we need to resume it to avoid a slowloris
            -- attack during request body sending.
            Handle -> IO ()
Timeout.resume Handle
timeoutHandle
            -- This doesn't need to be "atomic", since this is only used in
            -- 'recvRequest' to create the 'requestBody' function. And getting
            -- chunks of the request in a concurrent setting is asking for
            -- trouble anyway.
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef Bool
isFirstRef Bool
False

        ByteString
bs <- IO ByteString
rbody

        -- As soon as we finish receiving the request body, whether
        -- because the application is not interested in more bytes, or
        -- because there is no more data available, pause the timeout
        -- handler again.
        Bool
isEmpty <- ByteString -> IO Bool
checkEmpty ByteString
bs
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isEmpty (Handle -> IO ()
Timeout.pause Handle
timeoutHandle)

        ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

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

type BSEndo = S.ByteString -> S.ByteString
type BSEndoList = [ByteString] -> [ByteString]

data THStatus
    = THStatus
        Int -- running total byte count (excluding current header chunk)
        Int -- current header chunk byte count
        BSEndoList -- previously parsed lines
        BSEndo -- bytestrings to be prepended

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

{- FIXME
close :: Sink ByteString IO a
close = throwIO IncompleteHeaders
-}

-- | Assumes the 'ByteString' is never 'S.null'
push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src (THStatus Int
totalLen Int
chunkLen BSEndoList
reqLines BSEndo
prepend) ByteString
bs
    -- Newline found at index 'ix'
    | Just Int
ix <- Word8 -> ByteString -> Maybe Int
S.elemIndex Word8
_lf ByteString
bs = do
        -- Too many bytes
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
currentTotal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxTotalHeaderLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
OverLargeHeader
        Int -> IO [ByteString]
newlineFound Int
ix
    -- No newline found
    | Bool
otherwise = do
        -- Early easy abort
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
currentTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bsLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxTotalHeaderLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
OverLargeHeader
        (ByteString -> IO [ByteString]) -> IO [ByteString]
forall a. (ByteString -> IO a) -> IO a
withNewChunk ByteString -> IO [ByteString]
noNewlineFound
  where
    bsLen :: Int
bsLen = ByteString -> Int
S.length ByteString
bs
    currentTotal :: Int
currentTotal = Int
totalLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chunkLen
    {-# INLINE withNewChunk #-}
    withNewChunk :: (S.ByteString -> IO a) -> IO a
    withNewChunk :: forall a. (ByteString -> IO a) -> IO a
withNewChunk ByteString -> IO a
f = do
        ByteString
newChunk <- Source -> IO ByteString
readSource' Source
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
S.null ByteString
newChunk) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
throwIO InvalidRequest
IncompleteHeaders
        ByteString -> IO a
f ByteString
newChunk
    {-# INLINE noNewlineFound #-}
    noNewlineFound :: ByteString -> IO [ByteString]
noNewlineFound ByteString
newChunk
        -- The chunk split the CRLF in half
        | ByteString -> Word8
SU.unsafeLast ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
S.head ByteString
newChunk Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_lf =
            let bs' :: ByteString
bs' = Int -> BSEndo
SU.unsafeDrop Int
1 ByteString
newChunk
             in if Int
bsLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                -- first part is only CRLF, we're done
                then do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
S.null ByteString
bs') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> ByteString -> IO ()
leftoverSource Source
src ByteString
bs'
                    [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ BSEndoList
reqLines []
                else do
                    ByteString
rest <- if ByteString -> Bool
S.null ByteString
bs'
                        -- new chunk is only LF, we need more to check for multiline
                        then (ByteString -> IO ByteString) -> IO ByteString
forall a. (ByteString -> IO a) -> IO a
withNewChunk ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        else ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs'
                    let status :: THStatus
status = Int -> ByteString -> THStatus
addLine (Int
bsLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> BSEndo
SU.unsafeTake (Int
bsLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ByteString
bs)
                    Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src THStatus
status ByteString
rest
        -- chunk and keep going
        | Bool
otherwise = do
            let newChunkTotal :: Int
newChunkTotal = Int
chunkLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bsLen
                newPrepend :: BSEndo
newPrepend = BSEndo
prepend BSEndo -> BSEndo -> BSEndo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bs ByteString -> BSEndo
forall a. Semigroup a => a -> a -> a
<>)
                status :: THStatus
status = Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
totalLen Int
newChunkTotal BSEndoList
reqLines BSEndo
newPrepend
            Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src THStatus
status ByteString
newChunk
    {-# INLINE newlineFound #-}
    newlineFound :: Int -> IO [ByteString]
newlineFound Int
ix
        -- Is end of headers
        | Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
startsWithLF =  do
            let rest :: ByteString
rest = Int -> BSEndo
SU.unsafeDrop Int
end ByteString
bs
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
S.null ByteString
rest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> ByteString -> IO ()
leftoverSource Source
src ByteString
rest
            [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ BSEndoList
reqLines []
        | Bool
otherwise = do
            -- LF is on last byte
            let p :: Int
p = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                chunk :: Int
chunk =
                    if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& ByteString -> Int -> Word8
SU.unsafeIndex ByteString
bs Int
p Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr then Int
p else Int
ix
                status :: THStatus
status = Int -> ByteString -> THStatus
addLine Int
end (Int -> BSEndo
SU.unsafeTake Int
chunk ByteString
bs)
                continue :: ByteString -> IO [ByteString]
continue = Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src THStatus
status
            if Int
end Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bsLen
                then (ByteString -> IO [ByteString]) -> IO [ByteString]
forall a. (ByteString -> IO a) -> IO a
withNewChunk ByteString -> IO [ByteString]
continue
                else ByteString -> IO [ByteString]
continue (ByteString -> IO [ByteString]) -> ByteString -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Int -> BSEndo
SU.unsafeDrop Int
end ByteString
bs
      where
        end :: Int
end = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        startsWithLF :: Bool
startsWithLF =
            case Int
ix of
                Int
0 -> Bool
True
                Int
1 -> ByteString -> Word8
SU.unsafeHead ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr
                Int
_ -> Bool
False
    -- addLine: take the current chunk and, if there's nothing to prepend,
    -- add straight to 'reqLines', otherwise first prepend then add.
    {-# INLINE addLine #-}
    addLine :: Int -> ByteString -> THStatus
addLine Int
len ByteString
chunk =
        let newTotal :: Int
newTotal = Int
currentTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
            newLine :: ByteString
newLine =
                if Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ByteString
chunk else BSEndo
prepend ByteString
chunk
        in Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
newTotal Int
0 (BSEndoList
reqLines BSEndoList -> BSEndoList -> BSEndoList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
newLineByteString -> BSEndoList
forall a. a -> [a] -> [a]
:)) BSEndo
forall a. a -> a
id
{- HLint ignore push "Use unless" -}


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

getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)
getFileInfoKey :: Key (FilePath -> IO FileInfo)
getFileInfoKey = IO (Key (FilePath -> IO FileInfo)) -> Key (FilePath -> IO FileInfo)
forall a. IO a -> a
unsafePerformIO IO (Key (FilePath -> IO FileInfo))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE getFileInfoKey #-}

#ifdef MIN_VERSION_crypton_x509
getClientCertificateKey :: Vault.Key (Maybe CertificateChain)
getClientCertificateKey :: Key (Maybe CertificateChain)
getClientCertificateKey = IO (Key (Maybe CertificateChain)) -> Key (Maybe CertificateChain)
forall a. IO a -> a
unsafePerformIO IO (Key (Maybe CertificateChain))
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE getClientCertificateKey #-}
#endif