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

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

import qualified Control.Concurrent as Conc (yield)
import Data.Array ((!))
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 Data.Typeable (Typeable)
import qualified Data.Vault.Lazy as Vault
import Data.Word8 (_cr, _lf)
#ifdef MIN_VERSION_crypton_x509
import Data.X509
#endif
import UnliftIO (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.ReadInt
import Network.Wai.Handler.Warp.RequestHeader
import Network.Wai.Handler.Warp.Settings (
    Settings,
    settingsMaxTotalHeaderLength,
    settingsNoParsePath,
 )

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

-- | Receiving a HTTP request from 'Connection' and parsing its header
--   to create 'Request'.
recvRequest
    :: Bool
    -- ^ first request on this connection?
    -> Settings
    -> Connection
    -> InternalInfo
    -> Timeout.Handle
    -> SockAddr
    -- ^ Peer's address.
    -> Source
    -- ^ Where HTTP request comes from.
    -> Transport
    -> IO
        ( Request
        , Maybe (I.IORef Int)
        , IndexedHeader
        , 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 :: Bool
-> Settings
-> Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Source
-> Transport
-> IO (Request, Maybe (IORef Int), IndexedHeader, IO HeaderValue)
recvRequest Bool
firstRequest Settings
settings Connection
conn InternalInfo
ii Handle
th SockAddr
addr Source
src Transport
transport = do
    [HeaderValue]
hdrlines <- Int -> Bool -> Source -> IO [HeaderValue]
headerLines (Settings -> Int
settingsMaxTotalHeaderLength Settings
settings) Bool
firstRequest Source
src
    (HeaderValue
method, HeaderValue
unparsedPath, HeaderValue
path, HeaderValue
query, HttpVersion
httpversion, RequestHeaders
hdr) <-
        [HeaderValue]
-> IO
     (HeaderValue, HeaderValue, HeaderValue, HeaderValue, HttpVersion,
      RequestHeaders)
parseHeaderLines [HeaderValue]
hdrlines
    let idxhdr :: IndexedHeader
idxhdr = RequestHeaders -> IndexedHeader
indexRequestHeader RequestHeaders
hdr
        expect :: Maybe HeaderValue
expect = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqExpect
        handle100Continue :: IO ()
handle100Continue = Connection -> HttpVersion -> Maybe HeaderValue -> IO ()
handleExpect Connection
conn HttpVersion
httpversion Maybe HeaderValue
expect
    (IO HeaderValue
rbody, Maybe (IORef Int)
remainingRef, RequestBodyLength
bodyLength) <- Source
-> IndexedHeader
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src IndexedHeader
idxhdr
    -- body producing function which will produce '100-continue', if needed
    IO HeaderValue
rbody' <- Maybe (IORef Int)
-> Handle -> IO HeaderValue -> IO () -> IO (IO HeaderValue)
timeoutBody Maybe (IORef Int)
remainingRef Handle
th IO HeaderValue
rbody IO ()
handle100Continue
    -- body producing function which will never produce 100-continue
    IO HeaderValue
rbodyFlush <- Maybe (IORef Int)
-> Handle -> IO HeaderValue -> IO () -> IO (IO HeaderValue)
timeoutBody Maybe (IORef Int)
remainingRef Handle
th IO HeaderValue
rbody (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    let rawPath :: HeaderValue
rawPath = if Settings -> Bool
settingsNoParsePath Settings
settings then HeaderValue
unparsedPath else HeaderValue
path
        vaultValue :: 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 :: HeaderValue
requestMethod = HeaderValue
method
                , httpVersion :: HttpVersion
httpVersion = HttpVersion
httpversion
                , pathInfo :: [Text]
pathInfo = HeaderValue -> [Text]
H.decodePathSegments HeaderValue
path
                , rawPathInfo :: HeaderValue
rawPathInfo = HeaderValue
rawPath
                , rawQueryString :: HeaderValue
rawQueryString = HeaderValue
query
                , queryString :: Query
queryString = HeaderValue -> Query
H.parseQuery HeaderValue
query
                , requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
hdr
                , isSecure :: Bool
isSecure = Transport -> Bool
isTransportSecure Transport
transport
                , remoteHost :: SockAddr
remoteHost = SockAddr
addr
                , requestBody :: IO HeaderValue
requestBody = IO HeaderValue
rbody'
                , vault :: Vault
vault = Vault
vaultValue
                , requestBodyLength :: RequestBodyLength
requestBodyLength = RequestBodyLength
bodyLength
                , requestHeaderHost :: Maybe HeaderValue
requestHeaderHost = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqHost
                , requestHeaderRange :: Maybe HeaderValue
requestHeaderRange = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqRange
                , requestHeaderReferer :: Maybe HeaderValue
requestHeaderReferer = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqReferer
                , requestHeaderUserAgent :: Maybe HeaderValue
requestHeaderUserAgent = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqUserAgent
                }
    (Request, Maybe (IORef Int), IndexedHeader, IO HeaderValue)
-> IO (Request, Maybe (IORef Int), IndexedHeader, IO HeaderValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, Maybe (IORef Int)
remainingRef, IndexedHeader
idxhdr, IO HeaderValue
rbodyFlush)

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

headerLines :: Int -> Bool -> Source -> IO [ByteString]
headerLines :: Int -> Bool -> Source -> IO [HeaderValue]
headerLines Int
maxTotalHeaderLength Bool
firstRequest Source
src = do
    HeaderValue
bs <- Source -> IO HeaderValue
readSource Source
src
    if HeaderValue -> Bool
S.null HeaderValue
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.

            if Bool
firstRequest
                then InvalidRequest -> IO [HeaderValue]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
ConnectionClosedByPeer
                else NoKeepAliveRequest -> IO [HeaderValue]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO NoKeepAliveRequest
NoKeepAliveRequest
        else Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
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) HeaderValue
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, Typeable)
instance Exception NoKeepAliveRequest

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

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

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

bodyAndSource
    :: Source
    -> IndexedHeader
    -> IO
        ( IO ByteString
        , Maybe (I.IORef Int)
        , RequestBodyLength
        )
bodyAndSource :: Source
-> IndexedHeader
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src IndexedHeader
idxhdr
    | Bool
chunked = do
        CSource
csrc <- Source -> IO CSource
mkCSource Source
src
        (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CSource -> IO HeaderValue
readCSource CSource
csrc, Maybe (IORef Int)
forall a. Maybe a
Nothing, RequestBodyLength
ChunkedBody)
    | Bool
otherwise = do
        let len :: Int
len = Maybe HeaderValue -> Int
toLength (Maybe HeaderValue -> Int) -> Maybe HeaderValue -> Int
forall a b. (a -> b) -> a -> b
$ IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqContentLength
            bodyLen :: RequestBodyLength
bodyLen = 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
        isrc :: ISource
isrc@(ISource Source
_ IORef Int
remaining) <- Source -> Int -> IO ISource
mkISource Source
src Int
len
        (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ISource -> IO HeaderValue
readISource ISource
isrc, IORef Int -> Maybe (IORef Int)
forall a. a -> Maybe a
Just IORef Int
remaining, RequestBodyLength
bodyLen)
  where
    chunked :: Bool
chunked = Maybe HeaderValue -> Bool
isChunked (Maybe HeaderValue -> Bool) -> Maybe HeaderValue -> Bool
forall a b. (a -> b) -> a -> b
$ IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqTransferEncoding

toLength :: Maybe HeaderValue -> Int
toLength :: Maybe HeaderValue -> Int
toLength Maybe HeaderValue
Nothing = Int
0
toLength (Just HeaderValue
bs) = HeaderValue -> Int
forall a. Integral a => HeaderValue -> a
readInt HeaderValue
bs

isChunked :: Maybe HeaderValue -> Bool
isChunked :: Maybe HeaderValue -> Bool
isChunked (Just HeaderValue
bs) = BSEndo
forall s. FoldCase s => s -> s
CI.foldCase HeaderValue
bs HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"chunked"
isChunked Maybe HeaderValue
_ = Bool
False

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

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

    let checkEmpty :: HeaderValue -> 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)
-> (HeaderValue -> Bool) -> HeaderValue -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderValue -> Bool
S.null
                Just IORef Int
ref -> \HeaderValue
bs ->
                    if HeaderValue -> Bool
S.null HeaderValue
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 HeaderValue -> IO (IO HeaderValue)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO HeaderValue -> IO (IO HeaderValue))
-> IO HeaderValue -> IO (IO HeaderValue)
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
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef Bool
isFirstRef Bool
False

        HeaderValue
bs <- IO HeaderValue
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 <- HeaderValue -> IO Bool
checkEmpty HeaderValue
bs
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isEmpty (Handle -> IO ()
Timeout.pause Handle
timeoutHandle)

        HeaderValue -> IO HeaderValue
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderValue
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 -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src (THStatus Int
totalLen Int
chunkLen BSEndoList
reqLines BSEndo
prepend) HeaderValue
bs
    -- Newline found at index 'ix'
    | Just Int
ix <- Word8 -> HeaderValue -> Maybe Int
S.elemIndex Word8
_lf HeaderValue
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
OverLargeHeader
        Int -> IO [HeaderValue]
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 (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
OverLargeHeader
        (HeaderValue -> IO [HeaderValue]) -> IO [HeaderValue]
forall a. (HeaderValue -> IO a) -> IO a
withNewChunk HeaderValue -> IO [HeaderValue]
noNewlineFound
  where
    bsLen :: Int
bsLen = HeaderValue -> Int
S.length HeaderValue
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. (HeaderValue -> IO a) -> IO a
withNewChunk HeaderValue -> IO a
f = do
        HeaderValue
newChunk <- Source -> IO HeaderValue
readSource' Source
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderValue -> Bool
S.null HeaderValue
newChunk) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InvalidRequest -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
IncompleteHeaders
        HeaderValue -> IO a
f HeaderValue
newChunk
    {-# INLINE noNewlineFound #-}
    noNewlineFound :: HeaderValue -> IO [HeaderValue]
noNewlineFound HeaderValue
newChunk
        -- The chunk split the CRLF in half
        | HeaderValue -> Word8
SU.unsafeLast HeaderValue
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr Bool -> Bool -> Bool
&& HasCallStack => HeaderValue -> Word8
HeaderValue -> Word8
S.head HeaderValue
newChunk Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_lf =
            let bs' :: HeaderValue
bs' = Int -> BSEndo
SU.unsafeDrop Int
1 HeaderValue
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
$ HeaderValue -> Bool
S.null HeaderValue
bs') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> HeaderValue -> IO ()
leftoverSource Source
src HeaderValue
bs'
                    [HeaderValue] -> IO [HeaderValue]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HeaderValue] -> IO [HeaderValue])
-> [HeaderValue] -> IO [HeaderValue]
forall a b. (a -> b) -> a -> b
$ BSEndoList
reqLines []
                else do
                    HeaderValue
rest <- if HeaderValue -> Bool
S.null HeaderValue
bs'
                        -- new chunk is only LF, we need more to check for multiline
                        then (HeaderValue -> IO HeaderValue) -> IO HeaderValue
forall a. (HeaderValue -> IO a) -> IO a
withNewChunk HeaderValue -> IO HeaderValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        else HeaderValue -> IO HeaderValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeaderValue
bs'
                    let status :: THStatus
status = Int -> HeaderValue -> 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) HeaderValue
bs)
                    Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status HeaderValue
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
. (HeaderValue
bs HeaderValue -> 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 -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status HeaderValue
newChunk
    {-# INLINE newlineFound #-}
    newlineFound :: Int -> IO [HeaderValue]
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 :: HeaderValue
rest = Int -> BSEndo
SU.unsafeDrop Int
end HeaderValue
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
$ HeaderValue -> Bool
S.null HeaderValue
rest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> HeaderValue -> IO ()
leftoverSource Source
src HeaderValue
rest
            [HeaderValue] -> IO [HeaderValue]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HeaderValue] -> IO [HeaderValue])
-> [HeaderValue] -> IO [HeaderValue]
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
&& HeaderValue -> Int -> Word8
SU.unsafeIndex HeaderValue
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 -> HeaderValue -> THStatus
addLine Int
end (Int -> BSEndo
SU.unsafeTake Int
chunk HeaderValue
bs)
                continue :: HeaderValue -> IO [HeaderValue]
continue = Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status
            if Int
end Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bsLen
                then (HeaderValue -> IO [HeaderValue]) -> IO [HeaderValue]
forall a. (HeaderValue -> IO a) -> IO a
withNewChunk HeaderValue -> IO [HeaderValue]
continue
                else HeaderValue -> IO [HeaderValue]
continue (HeaderValue -> IO [HeaderValue])
-> HeaderValue -> IO [HeaderValue]
forall a b. (a -> b) -> a -> b
$ Int -> BSEndo
SU.unsafeDrop Int
end HeaderValue
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 -> HeaderValue -> Word8
SU.unsafeHead HeaderValue
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 -> HeaderValue -> THStatus
addLine Int
len HeaderValue
chunk =
        let newTotal :: Int
newTotal = Int
currentTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
            newLine :: HeaderValue
newLine =
                if Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then HeaderValue
chunk else BSEndo
prepend HeaderValue
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
. (HeaderValue
newLineHeaderValue -> 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