{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# 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 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
#ifdef MIN_VERSION_crypton_x509
import Data.X509
#endif
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)
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 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
        cl :: Maybe HeaderValue
cl = 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
        te :: Maybe HeaderValue
te = 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
        handle100Continue :: IO ()
handle100Continue = Connection -> HttpVersion -> Maybe HeaderValue -> IO ()
handleExpect Connection
conn HttpVersion
httpversion Maybe HeaderValue
expect
        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
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)
#ifdef MIN_VERSION_crypton_x509
                   (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)
#endif
                     Vault
Vault.empty
    (IO HeaderValue
rbody, Maybe (IORef Int)
remainingRef, RequestBodyLength
bodyLength) <- Source
-> Maybe HeaderValue
-> Maybe HeaderValue
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src Maybe HeaderValue
cl Maybe HeaderValue
te
    -- 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 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
        -- 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 [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
              -> Maybe HeaderValue -- ^ content length
              -> Maybe HeaderValue -- ^ transfer-encoding
              -> IO (IO ByteString
                    ,Maybe (I.IORef Int)
                    ,RequestBodyLength
                    )
bodyAndSource :: Source
-> Maybe HeaderValue
-> Maybe HeaderValue
-> IO (IO HeaderValue, Maybe (IORef Int), RequestBodyLength)
bodyAndSource Source
src Maybe HeaderValue
cl Maybe HeaderValue
te
  | 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
      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
    len :: Int
len = Maybe HeaderValue -> Int
toLength Maybe HeaderValue
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 HeaderValue -> Bool
isChunked Maybe HeaderValue
te

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 = 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 -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src (THStatus Int
totalLen Int
chunkLen BSEndoList
lines BSEndo
prepend) HeaderValue
bs'
        -- Too many bytes
        | Int
currentTotal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxTotalHeaderLength = InvalidRequest -> IO [HeaderValue]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO InvalidRequest
OverLargeHeader
        | Bool
otherwise = Maybe (Int, Int, Bool) -> IO [HeaderValue]
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 :: HeaderValue
bs = BSEndo
prepend HeaderValue
bs'
    bsLen :: Int
bsLen = HeaderValue -> Int
S.length HeaderValue
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 -> HeaderValue -> Maybe Int
S.elemIndex Word8
10 HeaderValue
bs'
        let headerNL :: Int
headerNL = Int
chunkNL Int -> Int -> Int
forall a. Num a => a -> a -> a
+ HeaderValue -> Int
S.length (BSEndo
prepend HeaderValue
"")
            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 = HasCallStack => HeaderValue -> Int -> Word8
HeaderValue -> Int -> Word8
S.index HeaderValue
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 -> HasCallStack => HeaderValue -> Int -> Word8
HeaderValue -> Int -> Word8
S.index HeaderValue
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 [HeaderValue]
push' Maybe (Int, Int, Bool)
Nothing = do
        HeaderValue
bst <- Source -> IO HeaderValue
readSource' Source
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderValue -> Bool
S.null HeaderValue
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 -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status HeaderValue
bst
      where
        prepend' :: BSEndo
prepend' = HeaderValue -> BSEndo
S.append HeaderValue
bs
        thisChunkLen :: Int
thisChunkLen = HeaderValue -> Int
S.length HeaderValue
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 -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status HeaderValue
rest
      where
        rest :: HeaderValue
rest = Int -> BSEndo
S.drop (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) HeaderValue
bs
        prepend' :: BSEndo
prepend' = HeaderValue -> BSEndo
S.append (Int -> BSEndo
SU.unsafeTake (HeaderValue -> Int -> Int
checkCR HeaderValue
bs Int
end) HeaderValue
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
      | HeaderValue -> Bool
S.null HeaderValue
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 -> HeaderValue -> IO ()
leftoverSource Source
src (Int -> BSEndo
SU.unsafeDrop Int
start HeaderValue
bs)
            [HeaderValue] -> IO [HeaderValue]
forall a. a -> IO a
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
. (HeaderValue
lineHeaderValue -> 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'' :: HeaderValue
bs'' = Int -> BSEndo
SU.unsafeDrop Int
start HeaderValue
bs
                              in Int -> Source -> THStatus -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status HeaderValue
bs''
                           else do
                             -- no more bytes in this chunk, ask for more
                             HeaderValue
bst <- Source -> IO HeaderValue
readSource' Source
src
                             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HeaderValue -> Bool
S.null HeaderValue
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 -> HeaderValue -> IO [HeaderValue]
push Int
maxTotalHeaderLength Source
src THStatus
status HeaderValue
bst
      where
        start :: Int
start = Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -- start of next chunk
        line :: HeaderValue
line = Int -> BSEndo
SU.unsafeTake (HeaderValue -> Int -> Int
checkCR HeaderValue
bs Int
end) HeaderValue
bs

{-# INLINE checkCR #-}
checkCR :: ByteString -> Int -> Int
checkCR :: HeaderValue -> Int -> Int
checkCR HeaderValue
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
== HasCallStack => HeaderValue -> Int -> Word8
HeaderValue -> Int -> Word8
S.index HeaderValue
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 #-}

#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