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

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

import qualified Control.Concurrent as Conc (yield)
import UnliftIO (throwIO, Exception)
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.X509
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 Prelude hiding (lines)
import System.IO.Unsafe (unsafePerformIO)
import qualified System.TimeManager as Timeout

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, lines)
import Network.Wai.Handler.Warp.ReadInt
import Network.Wai.Handler.Warp.RequestHeader
import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)

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

-- | 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 ByteString)
recvRequest Bool
firstRequest Settings
settings Connection
conn InternalInfo
ii Handle
th SockAddr
addr Source
src Transport
transport = do
    [ByteString]
hdrlines <- Int -> Bool -> Source -> IO [ByteString]
headerLines (Settings -> Int
settingsMaxTotalHeaderLength Settings
settings) Bool
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 :: IndexedHeader
idxhdr = RequestHeaders -> IndexedHeader
indexRequestHeader RequestHeaders
hdr
        expect :: Maybe ByteString
expect = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqExpect
        cl :: Maybe ByteString
cl = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqContentLength
        te :: Maybe ByteString
te = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqTransferEncoding
        handle100Continue :: IO ()
handle100Continue = Connection -> HttpVersion -> Maybe ByteString -> IO ()
handleExpect Connection
conn HttpVersion
httpversion Maybe ByteString
expect
        rawPath :: ByteString
rawPath = if Settings -> Bool
settingsNoParsePath Settings
settings then ByteString
unparsedPath else ByteString
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
forall a b. (a -> b) -> a -> b
$ 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 (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
    (IO ByteString
rbody, Maybe (IORef Int)
remainingRef, RequestBodyLength
bodyLength) <- Source
-> Maybe ByteString
-> Maybe ByteString
-> IO (IO ByteString, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src Maybe ByteString
cl Maybe ByteString
te
    -- 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 (m :: * -> *) a. Monad m => a -> m a
return ())
    let 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
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      = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqHost
          , requestHeaderRange :: Maybe ByteString
requestHeaderRange     = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqRange
          , requestHeaderReferer :: Maybe ByteString
requestHeaderReferer   = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqReferer
          , requestHeaderUserAgent :: Maybe ByteString
requestHeaderUserAgent = IndexedHeader
idxhdr IndexedHeader -> Int -> Maybe ByteString
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 ByteString)
-> IO (Request, Maybe (IORef Int), IndexedHeader, IO ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, Maybe (IORef Int)
remainingRef, IndexedHeader
idxhdr, IO ByteString
rbodyFlush)

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

headerLines :: Int -> Bool -> Source -> IO [ByteString]
headerLines :: Int -> Bool -> Source -> IO [ByteString]
headerLines Int
maxTotalHeaderLength Bool
firstRequest Source
src = do
    ByteString
bs <- Source -> IO ByteString
readSource Source
src
    if ByteString -> Bool
S.null ByteString
bs
        -- 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.
        then if Bool
firstRequest then InvalidRequest -> IO [ByteString]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
ConnectionClosedByPeer else NoKeepAliveRequest -> IO [ByteString]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m 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
showList :: [NoKeepAliveRequest] -> ShowS
$cshowList :: [NoKeepAliveRequest] -> ShowS
show :: NoKeepAliveRequest -> FilePath
$cshow :: NoKeepAliveRequest -> FilePath
showsPrec :: Int -> NoKeepAliveRequest -> ShowS
$cshowsPrec :: Int -> NoKeepAliveRequest -> ShowS
Show, Typeable)
instance Exception NoKeepAliveRequest

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

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 (m :: * -> *) a. Monad m => a -> m a
return ()

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

bodyAndSource :: Source
              -> Maybe HeaderValue -- ^ content length
              -> Maybe HeaderValue -- ^ transfer-encoding
              -> IO (IO ByteString
                    ,Maybe (I.IORef Int)
                    ,RequestBodyLength
                    )
bodyAndSource :: Source
-> Maybe ByteString
-> Maybe ByteString
-> IO (IO ByteString, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src Maybe ByteString
cl Maybe ByteString
te
  | Bool
chunked = do
      CSource
csrc <- Source -> IO CSource
mkCSource Source
src
      (IO ByteString, Maybe (IORef Int), RequestBodyLength)
-> IO (IO ByteString, Maybe (IORef Int), RequestBodyLength)
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)
  | Bool
otherwise = 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 (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, RequestBodyLength
bodyLen)
  where
    len :: Int
len = Maybe ByteString -> Int
toLength Maybe ByteString
cl
    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
    chunked :: Bool
chunked = Maybe ByteString -> Bool
isChunked Maybe ByteString
te

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

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

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

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 (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 (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 (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 (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
            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 (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

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

type BSEndo = ByteString -> 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
-}

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
lines BSEndo
prepend) ByteString
bs'
        -- Too many bytes
        | Int
currentTotal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxTotalHeaderLength = InvalidRequest -> IO [ByteString]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
OverLargeHeader
        | Bool
otherwise = Maybe (Int, Int, Bool) -> IO [ByteString]
push' Maybe (Int, Int, Bool)
mNL
  where
    currentTotal :: Int
currentTotal = Int
totalLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chunkLen
    -- bs: current header chunk, plus maybe (parts of) next header
    bs :: ByteString
bs = BSEndo
prepend ByteString
bs'
    bsLen :: Int
bsLen = ByteString -> Int
S.length ByteString
bs
    -- Maybe newline
    -- Returns: Maybe
    --    ( length of this chunk up to newline
    --    , position of newline in relation to entire current header
    --    , is this part of a multiline header
    --    )
    mNL :: Maybe (Int, Int, Bool)
mNL = do
        -- 10 is the code point for newline (\n)
        Int
chunkNL <- Word8 -> ByteString -> Maybe Int
S.elemIndex Word8
10 ByteString
bs'
        let headerNL :: Int
headerNL = Int
chunkNL Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length (BSEndo
prepend ByteString
"")
            chunkNLlen :: Int
chunkNLlen = Int
chunkNL Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        -- check if there are two more bytes in the bs
        -- if so, see if the second of those is a horizontal space
        if Int
bsLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
headerNL Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 then
            let c :: Word8
c = ByteString -> Int -> Word8
S.index ByteString
bs (Int
headerNL Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                b :: Bool
b = case Int
headerNL of
                      Int
0 -> Bool
True
                      Int
1 -> ByteString -> Int -> Word8
S.index ByteString
bs Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
13
                      Int
_ -> Bool
False
                isMultiline :: Bool
isMultiline = Bool -> Bool
not Bool
b Bool -> Bool -> Bool
&& (Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32 Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
9)
            in (Int, Int, Bool) -> Maybe (Int, Int, Bool)
forall a. a -> Maybe a
Just (Int
chunkNLlen, Int
headerNL, Bool
isMultiline)
            else
            (Int, Int, Bool) -> Maybe (Int, Int, Bool)
forall a. a -> Maybe a
Just (Int
chunkNLlen, Int
headerNL, Bool
False)

    {-# INLINE push' #-}
    push' :: Maybe (Int, Int, Bool) -> IO [ByteString]
    -- No newline find in this chunk.  Add it to the prepend,
    -- update the length, and continue processing.
    push' :: Maybe (Int, Int, Bool) -> IO [ByteString]
push' Maybe (Int, Int, Bool)
Nothing = do
        ByteString
bst <- Source -> IO ByteString
readSource' Source
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
S.null ByteString
bst) (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
        Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src THStatus
status ByteString
bst
      where
        prepend' :: BSEndo
prepend' = ByteString -> BSEndo
S.append ByteString
bs
        thisChunkLen :: Int
thisChunkLen = ByteString -> Int
S.length ByteString
bs'
        newChunkLen :: Int
newChunkLen = Int
chunkLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
thisChunkLen
        status :: THStatus
status = Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
totalLen Int
newChunkLen BSEndoList
lines BSEndo
prepend'
    -- Found a newline, but next line continues as a multiline header
    push' (Just (Int
chunkNLlen, Int
end, Bool
True)) =
        Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src THStatus
status ByteString
rest
      where
        rest :: ByteString
rest = Int -> BSEndo
S.drop (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bs
        prepend' :: BSEndo
prepend' = ByteString -> BSEndo
S.append (Int -> BSEndo
SU.unsafeTake (ByteString -> Int -> Int
checkCR ByteString
bs Int
end) ByteString
bs)
        -- If we'd just update the entire current chunk up to newline
        -- we wouldn't count all the dropped newlines in between.
        -- So update 'chunkLen' with current chunk up to newline
        -- and use 'chunkLen' later on to add to 'totalLen'.
        newChunkLen :: Int
newChunkLen = Int
chunkLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chunkNLlen
        status :: THStatus
status = Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
totalLen Int
newChunkLen BSEndoList
lines BSEndo
prepend'
    -- Found a newline at position end.
    push' (Just (Int
chunkNLlen, Int
end, Bool
False))
      -- leftover
      | ByteString -> Bool
S.null ByteString
line = do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bsLen) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> ByteString -> IO ()
leftoverSource Source
src (Int -> BSEndo
SU.unsafeDrop Int
start ByteString
bs)
            [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return (BSEndoList
lines [])
      -- more headers
      | Bool
otherwise   = let lines' :: BSEndoList
lines' = BSEndoList
lines BSEndoList -> BSEndoList -> BSEndoList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
lineByteString -> BSEndoList
forall a. a -> [a] -> [a]
:)
                          newTotalLength :: Int
newTotalLength = Int
totalLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chunkLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chunkNLlen
                          status :: THStatus
status = Int -> Int -> BSEndoList -> BSEndo -> THStatus
THStatus Int
newTotalLength Int
0 BSEndoList
lines' BSEndo
forall a. a -> a
id
                      in if Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bsLen then
                             -- more bytes in this chunk, push again
                             let bs'' :: ByteString
bs'' = Int -> BSEndo
SU.unsafeDrop Int
start ByteString
bs
                              in Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src THStatus
status ByteString
bs''
                           else do
                             -- no more bytes in this chunk, ask for more
                             ByteString
bst <- Source -> IO ByteString
readSource' Source
src
                             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
S.null ByteString
bs) (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
                             Int -> Source -> THStatus -> ByteString -> IO [ByteString]
push Int
maxTotalHeaderLength Source
src THStatus
status ByteString
bst
      where
        start :: Int
start = Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -- start of next chunk
        line :: ByteString
line = Int -> BSEndo
SU.unsafeTake (ByteString -> Int -> Int
checkCR ByteString
bs Int
end) ByteString
bs

{-# INLINE checkCR #-}
checkCR :: ByteString -> Int -> Int
checkCR :: ByteString -> Int -> Int
checkCR ByteString
bs Int
pos = if Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Word8
13 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int -> Word8
S.index ByteString
bs Int
p then Int
p else Int
pos -- 13 is CR (\r)
  where
    !p :: Int
p = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

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 #-}

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 #-}