{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}

-- | Some helpers for parsing data out of a raw WAI 'Request'.
module Network.Wai.Parse (
    parseHttpAccept,
    parseRequestBody,
    RequestBodyType (..),
    getRequestBodyType,
    sinkRequestBody,
    sinkRequestBodyEx,
    RequestParseException (..),
    BackEnd,
    lbsBackEnd,
    tempFileBackEnd,
    tempFileBackEndOpts,
    Param,
    File,
    FileInfo (..),
    parseContentType,
    ParseRequestBodyOptions,
    defaultParseRequestBodyOptions,
    noLimitParseRequestBodyOptions,
    parseRequestBodyEx,
    setMaxRequestKeyLength,
    clearMaxRequestKeyLength,
    setMaxRequestNumFiles,
    clearMaxRequestNumFiles,
    setMaxRequestFileSize,
    clearMaxRequestFileSize,
    setMaxRequestFilesSize,
    clearMaxRequestFilesSize,
    setMaxRequestParmsSize,
    clearMaxRequestParmsSize,
    setMaxHeaderLines,
    clearMaxHeaderLines,
    setMaxHeaderLineLength,
    clearMaxHeaderLineLength,
#if TEST
    Bound (..),
    findBound,
    sinkTillBound,
    killCR,
    killCRLF,
    takeLine,
#endif
) where

import Prelude hiding (lines)

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Exception (catchJust)
import qualified Control.Exception as E
import Control.Monad (guard, unless, when)
import Control.Monad.Trans.Resource (
    InternalState,
    allocate,
    register,
    release,
    runInternalState,
 )
import Data.Bifunctor (bimap)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.CaseInsensitive (mk)
import Data.Function (fix, on)
import Data.IORef
import Data.Int (Int64)
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Typeable
import Data.Word8
import Network.HTTP.Types (hContentType)
import qualified Network.HTTP.Types as H
import Network.Wai
import Network.Wai.Handler.Warp (InvalidRequest (..))
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (hClose, openBinaryTempFile)
import System.IO.Error (isDoesNotExistError)

breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
w ByteString
s =
    let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w) ByteString
s
     in (ByteString
x, Int -> ByteString -> ByteString
S.drop Int
1 ByteString
y)

-- | Parse the HTTP accept string to determine supported content types.
parseHttpAccept :: S.ByteString -> [S.ByteString]
parseHttpAccept :: ByteString -> [ByteString]
parseHttpAccept =
    ((ByteString, (Double, Int)) -> ByteString)
-> [(ByteString, (Double, Int))] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, (Double, Int)) -> ByteString
forall a b. (a, b) -> a
fst
        ([(ByteString, (Double, Int))] -> [ByteString])
-> (ByteString -> [(ByteString, (Double, Int))])
-> ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, (Double, Int))
 -> (ByteString, (Double, Int)) -> Ordering)
-> [(ByteString, (Double, Int))] -> [(ByteString, (Double, Int))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Double, Int) -> (Double, Int) -> Ordering
rcompare ((Double, Int) -> (Double, Int) -> Ordering)
-> ((ByteString, (Double, Int)) -> (Double, Int))
-> (ByteString, (Double, Int))
-> (ByteString, (Double, Int))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ByteString, (Double, Int)) -> (Double, Int)
forall a b. (a, b) -> b
snd)
        ([(ByteString, (Double, Int))] -> [(ByteString, (Double, Int))])
-> (ByteString -> [(ByteString, (Double, Int))])
-> ByteString
-> [(ByteString, (Double, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> (ByteString, (Double, Int)))
-> [ByteString] -> [(ByteString, (Double, Int))]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString, Double) -> (ByteString, (Double, Int))
forall {a}. (ByteString, a) -> (ByteString, (a, Int))
addSpecificity ((ByteString, Double) -> (ByteString, (Double, Int)))
-> (ByteString -> (ByteString, Double))
-> ByteString
-> (ByteString, (Double, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (ByteString, Double)
forall {b}. (Read b, Fractional b) => ByteString -> (ByteString, b)
grabQ)
        ([ByteString] -> [(ByteString, (Double, Int))])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ByteString, (Double, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
_comma
  where
    rcompare :: (Double, Int) -> (Double, Int) -> Ordering
    rcompare :: (Double, Int) -> (Double, Int) -> Ordering
rcompare = ((Double, Int) -> (Double, Int) -> Ordering)
-> (Double, Int) -> (Double, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Double, Int) -> (Double, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
    addSpecificity :: (ByteString, a) -> (ByteString, (a, Int))
addSpecificity (ByteString
s, a
q) =
        -- Prefer higher-specificity types
        let semicolons :: Int
semicolons = Word8 -> ByteString -> Int
S.count Word8
_semicolon ByteString
s
            stars :: Int
stars = Word8 -> ByteString -> Int
S.count Word8
_asterisk ByteString
s
         in (ByteString
s, (a
q, Int
semicolons Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stars))
    grabQ :: ByteString -> (ByteString, b)
grabQ ByteString
s =
        -- Stripping all spaces may be too harsh.
        -- Maybe just strip either side of semicolon?
        let (ByteString
s', ByteString
q) = ByteString -> ByteString -> (ByteString, ByteString)
S.breakSubstring ByteString
";q=" ((Word8 -> Bool) -> ByteString -> ByteString
S.filter (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_space) ByteString
s)
            q' :: ByteString
q' = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_semicolon) (Int -> ByteString -> ByteString
S.drop Int
3 ByteString
q)
         in (ByteString
s', ByteString -> b
forall {a}. (Read a, Fractional a) => ByteString -> a
readQ ByteString
q')
    readQ :: ByteString -> a
readQ ByteString
s = case ReadS a
forall a. Read a => ReadS a
reads ReadS a -> ReadS a
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
S8.unpack ByteString
s of
        (a
x, [Char]
_) : [(a, [Char])]
_ -> a
x
        [(a, [Char])]
_ -> a
1.0

-- | Store uploaded files in memory
lbsBackEnd
    :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString
lbsBackEnd :: forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd ignored1
_ ignored2
_ m ByteString
popper =
    ([ByteString] -> [ByteString]) -> m ByteString
loop [ByteString] -> [ByteString]
forall a. a -> a
id
  where
    loop :: ([ByteString] -> [ByteString]) -> m ByteString
loop [ByteString] -> [ByteString]
front = do
        ByteString
bs <- m ByteString
popper
        if ByteString -> Bool
S.null ByteString
bs
            then ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
            else ([ByteString] -> [ByteString]) -> m ByteString
loop (([ByteString] -> [ByteString]) -> m ByteString)
-> ([ByteString] -> [ByteString]) -> m ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)

-- | Save uploaded files on disk as temporary files
--
-- Note: starting with version 2.0, removal of temp files is registered with
-- the provided @InternalState@. It is the responsibility of the caller to
-- ensure that this @InternalState@ gets cleaned up.
tempFileBackEnd
    :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
tempFileBackEnd :: forall ignored1 ignored2.
InternalState -> ignored1 -> ignored2 -> IO ByteString -> IO [Char]
tempFileBackEnd = IO [Char]
-> [Char]
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO [Char]
forall ignored1 ignored2.
IO [Char]
-> [Char]
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO [Char]
tempFileBackEndOpts IO [Char]
getTemporaryDirectory [Char]
"webenc.buf"

-- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.
tempFileBackEndOpts
    :: IO FilePath
    -- ^ get temporary directory
    -> String
    -- ^ filename pattern
    -> InternalState
    -> ignored1
    -> ignored2
    -> IO S.ByteString
    -> IO FilePath
tempFileBackEndOpts :: forall ignored1 ignored2.
IO [Char]
-> [Char]
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO [Char]
tempFileBackEndOpts IO [Char]
getTmpDir [Char]
pattrn InternalState
internalState ignored1
_ ignored2
_ IO ByteString
popper = do
    (ReleaseKey
key, ([Char]
fp, Handle
h)) <-
        (ResourceT IO (ReleaseKey, ([Char], Handle))
 -> InternalState -> IO (ReleaseKey, ([Char], Handle)))
-> InternalState
-> ResourceT IO (ReleaseKey, ([Char], Handle))
-> IO (ReleaseKey, ([Char], Handle))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResourceT IO (ReleaseKey, ([Char], Handle))
-> InternalState -> IO (ReleaseKey, ([Char], Handle))
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState InternalState
internalState (ResourceT IO (ReleaseKey, ([Char], Handle))
 -> IO (ReleaseKey, ([Char], Handle)))
-> ResourceT IO (ReleaseKey, ([Char], Handle))
-> IO (ReleaseKey, ([Char], Handle))
forall a b. (a -> b) -> a -> b
$ IO ([Char], Handle)
-> (([Char], Handle) -> IO ())
-> ResourceT IO (ReleaseKey, ([Char], Handle))
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO ([Char], Handle)
it (Handle -> IO ()
hClose (Handle -> IO ())
-> (([Char], Handle) -> Handle) -> ([Char], Handle) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Handle) -> Handle
forall a b. (a, b) -> b
snd)
    ReleaseKey
_ <- ResourceT IO ReleaseKey -> InternalState -> IO ReleaseKey
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState (IO () -> ResourceT IO ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> ResourceT IO ReleaseKey)
-> IO () -> ResourceT IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFileQuiet [Char]
fp) InternalState
internalState
    (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
        ByteString
bs <- IO ByteString
popper
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Handle -> ByteString -> IO ()
S.hPut Handle
h ByteString
bs
            IO ()
loop
    ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
key
    [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
fp
  where
    it :: IO ([Char], Handle)
it = do
        [Char]
tempDir <- IO [Char]
getTmpDir
        [Char] -> [Char] -> IO ([Char], Handle)
openBinaryTempFile [Char]
tempDir [Char]
pattrn
    removeFileQuiet :: [Char] -> IO ()
removeFileQuiet [Char]
fp =
        (IOError -> Maybe ()) -> IO () -> (() -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust
            (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
            ([Char] -> IO ()
removeFile [Char]
fp)
            (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | A data structure that describes the behavior of
-- the parseRequestBodyEx function.
--
-- @since 3.0.16.0
data ParseRequestBodyOptions = ParseRequestBodyOptions
    { ParseRequestBodyOptions -> Maybe Int
prboKeyLength :: Maybe Int
    -- ^ The maximum length of a filename
    , ParseRequestBodyOptions -> Maybe Int
prboMaxNumFiles :: Maybe Int
    -- ^ The maximum number of files.
    , ParseRequestBodyOptions -> Maybe Int64
prboMaxFileSize :: Maybe Int64
    -- ^ The maximum filesize per file.
    , ParseRequestBodyOptions -> Maybe Int64
prboMaxFilesSize :: Maybe Int64
    -- ^ The maximum total filesize.
    , ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize :: Maybe Int
    -- ^ The maximum size of the sum of all parameters
    , ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLines :: Maybe Int
    -- ^ The maximum header lines per mime/multipart entry
    , ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength :: Maybe Int
    -- ^ The maximum header line length per mime/multipart entry
    }

-- | Set the maximum length of a filename.
--
-- @since 3.0.16.0
setMaxRequestKeyLength
    :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestKeyLength Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboKeyLength = Just l}

-- | Do not limit the length of filenames.
--
-- @since 3.0.16.0
clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestKeyLength ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboKeyLength = Nothing}

-- | Set the maximum number of files per request.
--
-- @since 3.0.16.0
setMaxRequestNumFiles
    :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestNumFiles Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxNumFiles = Just l}

-- | Do not limit the maximum number of files per request.
--
-- @since 3.0.16.0
clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestNumFiles ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxNumFiles = Nothing}

-- | Set the maximum filesize per file (in bytes).
--
-- @since 3.0.16.0
setMaxRequestFileSize
    :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFileSize Int64
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxFileSize = Just l}

-- | Do not limit the maximum filesize per file.
--
-- @since 3.0.16.0
clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFileSize ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxFileSize = Nothing}

-- | Set the maximum size of all files per request.
--
-- @since 3.0.16.0
setMaxRequestFilesSize
    :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFilesSize Int64
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxFilesSize = Just l}

-- | Do not limit the maximum size of all files per request.
--
-- @since 3.0.16.0
clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFilesSize ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxFilesSize = Nothing}

-- | Set the maximum size of the sum of all parameters.
--
-- @since 3.0.16.0
setMaxRequestParmsSize
    :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestParmsSize Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxParmsSize = Just l}

-- | Do not limit the maximum size of the sum of all parameters.
--
-- @since 3.0.16.0
clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestParmsSize ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxParmsSize = Nothing}

-- | Set the maximum header lines per mime/multipart entry.
--
-- @since 3.0.16.0
setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxHeaderLines Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxHeaderLines = Just l}

-- | Do not limit the maximum header lines per mime/multipart entry.
--
-- @since 3.0.16.0
clearMaxHeaderLines :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxHeaderLines :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxHeaderLines ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxHeaderLines = Nothing}

-- | Set the maximum header line length per mime/multipart entry.
--
-- @since 3.0.16.0
setMaxHeaderLineLength
    :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxHeaderLineLength Int
l ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxHeaderLineLength = Just l}

-- | Do not limit the maximum header lines per mime/multipart entry.
--
-- @since 3.0.16.0
clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxHeaderLineLength ParseRequestBodyOptions
p = ParseRequestBodyOptions
p{prboMaxHeaderLineLength = Nothing}

-- | A reasonable default set of parsing options.
-- Maximum key/filename length: 32 bytes;
-- maximum files: 10; filesize unlimited; maximum
-- size for parameters: 64kbytes; maximum number of header
-- lines: 32 bytes (applies only to headers of a mime/multipart message);
-- maximum header line length: Apache's default for that is 8190 bytes
-- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline)
-- so we're using that here as well.
--
-- @since 3.0.16.0
defaultParseRequestBodyOptions :: ParseRequestBodyOptions
defaultParseRequestBodyOptions :: ParseRequestBodyOptions
defaultParseRequestBodyOptions =
    ParseRequestBodyOptions
        { prboKeyLength :: Maybe Int
prboKeyLength = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
32
        , prboMaxNumFiles :: Maybe Int
prboMaxNumFiles = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
10
        , prboMaxFileSize :: Maybe Int64
prboMaxFileSize = Maybe Int64
forall a. Maybe a
Nothing
        , prboMaxFilesSize :: Maybe Int64
prboMaxFilesSize = Maybe Int64
forall a. Maybe a
Nothing
        , prboMaxParmsSize :: Maybe Int
prboMaxParmsSize = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
65336
        , prboMaxHeaderLines :: Maybe Int
prboMaxHeaderLines = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
32
        , prboMaxHeaderLineLength :: Maybe Int
prboMaxHeaderLineLength = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8190
        }

-- | Do not impose any memory limits.
--
-- @since 3.0.21.0
noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
noLimitParseRequestBodyOptions =
    ParseRequestBodyOptions
        { prboKeyLength :: Maybe Int
prboKeyLength = Maybe Int
forall a. Maybe a
Nothing
        , prboMaxNumFiles :: Maybe Int
prboMaxNumFiles = Maybe Int
forall a. Maybe a
Nothing
        , prboMaxFileSize :: Maybe Int64
prboMaxFileSize = Maybe Int64
forall a. Maybe a
Nothing
        , prboMaxFilesSize :: Maybe Int64
prboMaxFilesSize = Maybe Int64
forall a. Maybe a
Nothing
        , prboMaxParmsSize :: Maybe Int
prboMaxParmsSize = Maybe Int
forall a. Maybe a
Nothing
        , prboMaxHeaderLines :: Maybe Int
prboMaxHeaderLines = Maybe Int
forall a. Maybe a
Nothing
        , prboMaxHeaderLineLength :: Maybe Int
prboMaxHeaderLineLength = Maybe Int
forall a. Maybe a
Nothing
        }

-- | Information on an uploaded file.
data FileInfo c = FileInfo
    { forall c. FileInfo c -> ByteString
fileName :: S.ByteString
    , forall c. FileInfo c -> ByteString
fileContentType :: S.ByteString
    , forall c. FileInfo c -> c
fileContent :: c
    }
    deriving (FileInfo c -> FileInfo c -> Bool
(FileInfo c -> FileInfo c -> Bool)
-> (FileInfo c -> FileInfo c -> Bool) -> Eq (FileInfo c)
forall c. Eq c => FileInfo c -> FileInfo c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Eq c => FileInfo c -> FileInfo c -> Bool
== :: FileInfo c -> FileInfo c -> Bool
$c/= :: forall c. Eq c => FileInfo c -> FileInfo c -> Bool
/= :: FileInfo c -> FileInfo c -> Bool
Eq, Int -> FileInfo c -> ShowS
[FileInfo c] -> ShowS
FileInfo c -> [Char]
(Int -> FileInfo c -> ShowS)
-> (FileInfo c -> [Char])
-> ([FileInfo c] -> ShowS)
-> Show (FileInfo c)
forall c. Show c => Int -> FileInfo c -> ShowS
forall c. Show c => [FileInfo c] -> ShowS
forall c. Show c => FileInfo c -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> FileInfo c -> ShowS
showsPrec :: Int -> FileInfo c -> ShowS
$cshow :: forall c. Show c => FileInfo c -> [Char]
show :: FileInfo c -> [Char]
$cshowList :: forall c. Show c => [FileInfo c] -> ShowS
showList :: [FileInfo c] -> ShowS
Show)

-- | Post parameter name and value.
type Param = (S.ByteString, S.ByteString)

-- | Post parameter name and associated file information.
type File y = (S.ByteString, FileInfo y)

-- | A file uploading backend. Takes the parameter name, file name, and a
-- stream of data.
type BackEnd a =
    S.ByteString
    -- ^ parameter name
    -> FileInfo ()
    -> IO S.ByteString
    -> IO a

-- | The mimetype of the http body.
-- Depending on whether just parameters or parameters and files
-- are passed, one or the other mimetype should be used.
data RequestBodyType
    = -- | application/x-www-form-urlencoded (parameters only)
      UrlEncoded
    | -- | multipart/form-data (parameters and files)
      Multipart S.ByteString

-- | Get the mimetype of the body of an http request.
getRequestBodyType :: Request -> Maybe RequestBodyType
getRequestBodyType :: Request -> Maybe RequestBodyType
getRequestBodyType Request
req = do
    ByteString
ctype' <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
    let (ByteString
ctype, [(ByteString, ByteString)]
attrs) = ByteString -> (ByteString, [(ByteString, ByteString)])
parseContentType ByteString
ctype'
    case ByteString
ctype of
        ByteString
"application/x-www-form-urlencoded" -> RequestBodyType -> Maybe RequestBodyType
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return RequestBodyType
UrlEncoded
        ByteString
"multipart/form-data" | Just ByteString
bound <- ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"boundary" [(ByteString, ByteString)]
attrs -> RequestBodyType -> Maybe RequestBodyType
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestBodyType -> Maybe RequestBodyType)
-> RequestBodyType -> Maybe RequestBodyType
forall a b. (a -> b) -> a -> b
$ ByteString -> RequestBodyType
Multipart ByteString
bound
        ByteString
_ -> Maybe RequestBodyType
forall a. Maybe a
Nothing

-- | Parse a content type value, turning a single @ByteString@ into the actual
-- content type and a list of pairs of attributes.
--
-- @since 1.3.2
parseContentType
    :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
parseContentType :: ByteString -> (ByteString, [(ByteString, ByteString)])
parseContentType ByteString
a = do
    let (ByteString
ctype, ByteString
b) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_semicolon) ByteString
a
        attrs :: [(ByteString, ByteString)]
attrs = ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall {c}. ([(ByteString, ByteString)] -> c) -> ByteString -> c
goAttrs [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> a
id (ByteString -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
b
     in (ByteString
ctype, [(ByteString, ByteString)]
attrs)
  where
    dq :: ByteString -> ByteString
dq ByteString
s =
        if ByteString -> Int
S.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
S.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_quotedbl Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
S.last ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_quotedbl
            then HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init ByteString
s
            else ByteString
s
    goAttrs :: ([(ByteString, ByteString)] -> c) -> ByteString -> c
goAttrs [(ByteString, ByteString)] -> c
front ByteString
bs
        | ByteString -> Bool
S.null ByteString
bs = [(ByteString, ByteString)] -> c
front []
        | Bool
otherwise =
            let (ByteString
x, ByteString
rest) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_semicolon) ByteString
bs
             in ([(ByteString, ByteString)] -> c) -> ByteString -> c
goAttrs ([(ByteString, ByteString)] -> c
front ([(ByteString, ByteString)] -> c)
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> (ByteString, ByteString)
goAttr ByteString
x (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:)) (ByteString -> c) -> ByteString -> c
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
rest
    goAttr :: ByteString -> (ByteString, ByteString)
goAttr ByteString
bs =
        let (ByteString
k, ByteString
v') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_equal) ByteString
bs
            v :: ByteString
v = Int -> ByteString -> ByteString
S.drop Int
1 ByteString
v'
         in (ByteString -> ByteString
strip ByteString
k, ByteString -> ByteString
dq (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
strip ByteString
v)
    strip :: ByteString -> ByteString
strip = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.breakEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_space)

-- | Parse the body of an HTTP request.
-- See parseRequestBodyEx for details.
-- Note: This function does not limit the memory it allocates.
-- When dealing with untrusted data (as is usually the case when
-- receiving input from the internet), it is recommended to
-- use the 'parseRequestBodyEx' function instead.
--
-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
parseRequestBody
    :: BackEnd y
    -> Request
    -> IO ([Param], [File y])
parseRequestBody :: forall y.
BackEnd y -> Request -> IO ([(ByteString, ByteString)], [File y])
parseRequestBody = ParseRequestBodyOptions
-> BackEnd y
-> Request
-> IO ([(ByteString, ByteString)], [File y])
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> Request
-> IO ([(ByteString, ByteString)], [File y])
parseRequestBodyEx ParseRequestBodyOptions
noLimitParseRequestBodyOptions

-- | Parse the body of an HTTP request, limit resource usage.
-- The HTTP body can contain both parameters and files.
-- This function will return a list of key,value pairs
-- for all parameters, and a list of key,a pairs
-- for filenames. The a depends on the used backend that
-- is responsible for storing the received files.
--
-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
parseRequestBodyEx
    :: ParseRequestBodyOptions
    -> BackEnd y
    -> Request
    -> IO ([Param], [File y])
parseRequestBodyEx :: forall y.
ParseRequestBodyOptions
-> BackEnd y
-> Request
-> IO ([(ByteString, ByteString)], [File y])
parseRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s Request
r =
    case Request -> Maybe RequestBodyType
getRequestBodyType Request
r of
        Maybe RequestBodyType
Nothing -> ([(ByteString, ByteString)], [File y])
-> IO ([(ByteString, ByteString)], [File y])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
        Just RequestBodyType
rbt -> ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s RequestBodyType
rbt (Request -> IO ByteString
getRequestBodyChunk Request
r)

-- | since 3.1.15 : throws 'RequestParseException' if something goes wrong
sinkRequestBody
    :: BackEnd y
    -> RequestBodyType
    -> IO S.ByteString
    -> IO ([Param], [File y])
sinkRequestBody :: forall y.
BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBody = ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBodyEx ParseRequestBodyOptions
noLimitParseRequestBodyOptions

-- | Throws 'RequestParseException' if something goes wrong
--
-- @since 3.0.16.0
--
-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
sinkRequestBodyEx
    :: ParseRequestBodyOptions
    -> BackEnd y
    -> RequestBodyType
    -> IO S.ByteString
    -> IO ([Param], [File y])
sinkRequestBodyEx :: forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s RequestBodyType
r IO ByteString
body = do
    IORef ([(ByteString, ByteString)], [File y])
ref <- ([(ByteString, ByteString)], [File y])
-> IO (IORef ([(ByteString, ByteString)], [File y]))
forall a. a -> IO (IORef a)
newIORef ([], [])
    let add :: Either (ByteString, ByteString) (File y) -> IO ()
add Either (ByteString, ByteString) (File y)
x = IORef ([(ByteString, ByteString)], [File y])
-> (([(ByteString, ByteString)], [File y])
    -> (([(ByteString, ByteString)], [File y]), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ([(ByteString, ByteString)], [File y])
ref ((([(ByteString, ByteString)], [File y])
  -> (([(ByteString, ByteString)], [File y]), ()))
 -> IO ())
-> (([(ByteString, ByteString)], [File y])
    -> (([(ByteString, ByteString)], [File y]), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \([(ByteString, ByteString)]
y, [File y]
z) ->
            case Either (ByteString, ByteString) (File y)
x of
                Left (ByteString, ByteString)
y' -> (((ByteString, ByteString)
y' (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString, ByteString)]
y, [File y]
z), ())
                Right File y
z' -> (([(ByteString, ByteString)]
y, File y
z' File y -> [File y] -> [File y]
forall a. a -> [a] -> [a]
: [File y]
z), ())
    ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
conduitRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s RequestBodyType
r IO ByteString
body Either (ByteString, ByteString) (File y) -> IO ()
add
    ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ([File y] -> [File y])
-> ([(ByteString, ByteString)], [File y])
-> ([(ByteString, ByteString)], [File y])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a]
reverse [File y] -> [File y]
forall a. [a] -> [a]
reverse (([(ByteString, ByteString)], [File y])
 -> ([(ByteString, ByteString)], [File y]))
-> IO ([(ByteString, ByteString)], [File y])
-> IO ([(ByteString, ByteString)], [File y])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ([(ByteString, ByteString)], [File y])
-> IO ([(ByteString, ByteString)], [File y])
forall a. IORef a -> IO a
readIORef IORef ([(ByteString, ByteString)], [File y])
ref

conduitRequestBodyEx
    :: ParseRequestBodyOptions
    -> BackEnd y
    -> RequestBodyType
    -> IO S.ByteString
    -> (Either Param (File y) -> IO ())
    -> IO ()
conduitRequestBodyEx :: forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
conduitRequestBodyEx ParseRequestBodyOptions
o BackEnd y
_ RequestBodyType
UrlEncoded IO ByteString
rbody Either (ByteString, ByteString) (File y) -> IO ()
add = do
    -- NOTE: in general, url-encoded data will be in a single chunk.
    -- Therefore, I'm optimizing for the usual case by sticking with
    -- strict byte strings here.
    let loop :: Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
size [ByteString] -> [ByteString]
front = do
            ByteString
bs <- IO ByteString
rbody
            if ByteString -> Bool
S.null ByteString
bs
                then ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
                else do
                    let newsize :: Int
newsize = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                    case ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o of
                        Just Int
maxSize ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newsize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                RequestParseException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (RequestParseException -> IO ()) -> RequestParseException -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    Int -> RequestParseException
MaxParamSizeExceeded Int
newsize
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
newsize (([ByteString] -> [ByteString]) -> IO ByteString)
-> ([ByteString] -> [ByteString]) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)
    ByteString
bs <- Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
0 [ByteString] -> [ByteString]
forall a. a -> a
id
    ((ByteString, ByteString) -> IO ())
-> [(ByteString, ByteString)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Either (ByteString, ByteString) (File y) -> IO ()
add (Either (ByteString, ByteString) (File y) -> IO ())
-> ((ByteString, ByteString)
    -> Either (ByteString, ByteString) (File y))
-> (ByteString, ByteString)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString)
-> Either (ByteString, ByteString) (File y)
forall a b. a -> Either a b
Left) ([(ByteString, ByteString)] -> IO ())
-> [(ByteString, ByteString)] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
H.parseSimpleQuery ByteString
bs
conduitRequestBodyEx ParseRequestBodyOptions
o BackEnd y
backend (Multipart ByteString
bound) IO ByteString
rbody Either (ByteString, ByteString) (File y) -> IO ()
add =
    ParseRequestBodyOptions
-> BackEnd y
-> ByteString
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
forall y.
ParseRequestBodyOptions
-> BackEnd y
-> ByteString
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
parsePiecesEx ParseRequestBodyOptions
o BackEnd y
backend ([Char] -> ByteString
S8.pack [Char]
"--" ByteString -> ByteString -> ByteString
`S.append` ByteString
bound) IO ByteString
rbody Either (ByteString, ByteString) (File y) -> IO ()
add

-- | Take one header or subheader line.
-- Since:  3.0.26
--  Throw 431 if headers too large.
takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
takeLine :: Maybe Int -> Source -> IO (Maybe ByteString)
takeLine Maybe Int
maxlen Source
src =
    ByteString -> IO (Maybe ByteString)
go ByteString
""
  where
    go :: ByteString -> IO (Maybe ByteString)
go ByteString
front = do
        ByteString
bs <- Source -> IO ByteString
readSource Source
src
        case Maybe Int
maxlen of
            Just Int
maxlen' ->
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
front Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxlen') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO InvalidRequest
RequestHeaderFieldsTooLarge
            Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        if ByteString -> Bool
S.null ByteString
bs
            then ByteString -> IO (Maybe ByteString)
close ByteString
front
            else ByteString -> ByteString -> IO (Maybe ByteString)
push ByteString
front ByteString
bs

    close :: ByteString -> IO (Maybe ByteString)
close ByteString
front = Source -> ByteString -> IO ()
leftover Source
src ByteString
front IO () -> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
    push :: ByteString -> ByteString -> IO (Maybe ByteString)
push ByteString
front ByteString
bs = do
        let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_lf) ByteString
bs
         in if ByteString -> Bool
S.null ByteString
y
                then ByteString -> IO (Maybe ByteString)
go (ByteString -> IO (Maybe ByteString))
-> ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
front ByteString -> ByteString -> ByteString
`S.append` ByteString
x
                else do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Source -> ByteString -> IO ()
leftover Source
src (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
y
                    let res :: ByteString
res = ByteString
front ByteString -> ByteString -> ByteString
`S.append` ByteString
x
                    case Maybe Int
maxlen of
                        Just Int
maxlen' ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
res Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxlen') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO InvalidRequest
RequestHeaderFieldsTooLarge
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> (ByteString -> Maybe ByteString)
-> ByteString
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> IO (Maybe ByteString))
-> ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
killCR ByteString
res

-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines' Maybe Int
lineLength Maybe Int
maxLines Source
source =
    [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString] -> Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'' [] Maybe Int
lineLength Maybe Int
maxLines Source
source

-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
takeLines''
    :: [S.ByteString]
    -> Maybe Int
    -> Maybe Int
    -> Source
    -> IO [S.ByteString]
takeLines'' :: [ByteString] -> Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'' [ByteString]
lines Maybe Int
lineLength Maybe Int
maxLines Source
src = do
    case Maybe Int
maxLines of
        Just Int
maxLines' ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
lines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLines') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                RequestParseException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (RequestParseException -> IO ()) -> RequestParseException -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Int -> RequestParseException
TooManyHeaderLines ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
lines)
        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe ByteString
res <- Maybe Int -> Source -> IO (Maybe ByteString)
takeLine Maybe Int
lineLength Source
src
    case Maybe ByteString
res of
        Maybe ByteString
Nothing -> [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
lines
        Just ByteString
l
            | ByteString -> Bool
S.null ByteString
l -> [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
lines
            | Bool
otherwise -> [ByteString] -> Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'' (ByteString
l ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
lines) Maybe Int
lineLength Maybe Int
maxLines Source
src

data Source = Source (IO S.ByteString) (IORef S.ByteString)

mkSource :: IO S.ByteString -> IO Source
mkSource :: IO ByteString -> IO Source
mkSource IO ByteString
f = do
    IORef ByteString
ref <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
S.empty
    Source -> IO Source
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Source -> IO Source) -> Source -> IO Source
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IORef ByteString -> Source
Source IO ByteString
f IORef ByteString
ref

readSource :: Source -> IO S.ByteString
readSource :: Source -> IO ByteString
readSource (Source IO ByteString
f IORef ByteString
ref) = do
    ByteString
bs <- IORef ByteString
-> (ByteString -> (ByteString, ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ByteString
ref ((ByteString -> (ByteString, ByteString)) -> IO ByteString)
-> (ByteString -> (ByteString, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> (ByteString
S.empty, ByteString
bs)
    if ByteString -> Bool
S.null ByteString
bs
        then IO ByteString
f
        else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

{- HLint ignore readSource "Use tuple-section" -}

leftover :: Source -> S.ByteString -> IO ()
leftover :: Source -> ByteString -> IO ()
leftover (Source IO ByteString
_ IORef ByteString
ref) = IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
ref

-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
parsePiecesEx
    :: ParseRequestBodyOptions
    -> BackEnd y
    -> S.ByteString
    -> IO S.ByteString
    -> (Either Param (File y) -> IO ())
    -> IO ()
parsePiecesEx :: forall y.
ParseRequestBodyOptions
-> BackEnd y
-> ByteString
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
parsePiecesEx ParseRequestBodyOptions
o BackEnd y
sink ByteString
bound IO ByteString
rbody Either (ByteString, ByteString) (File y) -> IO ()
add =
    IO ByteString -> IO Source
mkSource IO ByteString
rbody IO Source -> (Source -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
0 Int
0 Int
0 Int64
0
  where
    loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
    loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms Int
numFiles Int
parmSize Int64
filesSize Source
src = do
        Maybe ByteString
_boundLine <- Maybe Int -> Source -> IO (Maybe ByteString)
takeLine (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength ParseRequestBodyOptions
o) Source
src
        [ByteString]
res' <-
            Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'
                (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength ParseRequestBodyOptions
o)
                (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLines ParseRequestBodyOptions
o)
                Source
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
res') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let ls' :: [(HeaderName, ByteString)]
ls' = (ByteString -> (HeaderName, ByteString))
-> [ByteString] -> [(HeaderName, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (HeaderName, ByteString)
parsePair [ByteString]
res'
            let x :: Maybe (Maybe ByteString, ByteString, Maybe ByteString)
x = do
                    ByteString
cd <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contDisp [(HeaderName, ByteString)]
ls'
                    let ct :: Maybe ByteString
ct = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contType [(HeaderName, ByteString)]
ls'
                    let attrs :: [(ByteString, ByteString)]
attrs = ByteString -> [(ByteString, ByteString)]
parseAttrs ByteString
cd
                    ByteString
name <- ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"name" [(ByteString, ByteString)]
attrs
                    (Maybe ByteString, ByteString, Maybe ByteString)
-> Maybe (Maybe ByteString, ByteString, Maybe ByteString)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
ct, ByteString
name, ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"filename" [(ByteString, ByteString)]
attrs)
            case Maybe (Maybe ByteString, ByteString, Maybe ByteString)
x of
                Just (Maybe ByteString
mct, ByteString
name, Just ByteString
filename) -> do
                    case ParseRequestBodyOptions -> Maybe Int
prboKeyLength ParseRequestBodyOptions
o of
                        Just Int
maxKeyLength ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxKeyLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                RequestParseException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (RequestParseException -> IO ()) -> RequestParseException -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    ByteString -> Int -> RequestParseException
FilenameTooLong ByteString
name Int
maxKeyLength
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    case ParseRequestBodyOptions -> Maybe Int
prboMaxNumFiles ParseRequestBodyOptions
o of
                        Just Int
maxFiles ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numFiles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxFiles) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                RequestParseException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (RequestParseException -> IO ()) -> RequestParseException -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    Int -> RequestParseException
MaxFileNumberExceeded Int
numFiles
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    let ct :: ByteString
ct = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octet-stream" Maybe ByteString
mct
                        fi0 :: FileInfo ()
fi0 = ByteString -> ByteString -> () -> FileInfo ()
forall c. ByteString -> ByteString -> c -> FileInfo c
FileInfo ByteString
filename ByteString
ct ()
                        fs :: [Int64]
fs =
                            [Maybe Int64] -> [Int64]
forall a. [Maybe a] -> [a]
catMaybes
                                [ ParseRequestBodyOptions -> Maybe Int64
prboMaxFileSize ParseRequestBodyOptions
o
                                , Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
subtract Int64
filesSize (Int64 -> Int64) -> Maybe Int64 -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseRequestBodyOptions -> Maybe Int64
prboMaxFilesSize ParseRequestBodyOptions
o
                                ]
                        mfs :: Maybe Int64
mfs = if [Int64] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int64]
fs then Maybe Int64
forall a. Maybe a
Nothing else Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ [Int64] -> Int64
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int64]
fs
                    ((Bool
wasFound, Int64
fileSize), y
y) <- ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
forall y.
ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
sinkTillBound' ByteString
bound ByteString
name FileInfo ()
fi0 BackEnd y
sink Source
src Maybe Int64
mfs
                    let newFilesSize :: Int64
newFilesSize = Int64
filesSize Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
fileSize
                    Either (ByteString, ByteString) (File y) -> IO ()
add (Either (ByteString, ByteString) (File y) -> IO ())
-> Either (ByteString, ByteString) (File y) -> IO ()
forall a b. (a -> b) -> a -> b
$ File y -> Either (ByteString, ByteString) (File y)
forall a b. b -> Either a b
Right (ByteString
name, FileInfo ()
fi0{fileContent = y})
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms (Int
numFiles Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
parmSize Int64
newFilesSize Source
src
                Just (Maybe ByteString
_ct, ByteString
name, Maybe ByteString
Nothing) -> do
                    case ParseRequestBodyOptions -> Maybe Int
prboKeyLength ParseRequestBodyOptions
o of
                        Just Int
maxKeyLength ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxKeyLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                RequestParseException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (RequestParseException -> IO ()) -> RequestParseException -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    ByteString -> Int -> RequestParseException
ParamNameTooLong ByteString
name Int
maxKeyLength
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    let seed :: a -> a
seed = a -> a
forall a. a -> a
id
                    let iter :: ([a] -> c) -> a -> m ([a] -> c)
iter [a] -> c
front a
bs = ([a] -> c) -> m ([a] -> c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (([a] -> c) -> m ([a] -> c)) -> ([a] -> c) -> m ([a] -> c)
forall a b. (a -> b) -> a -> b
$ [a] -> c
front ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) a
bs
                    ((Bool
wasFound, Int64
_fileSize), [ByteString] -> [ByteString]
front) <-
                        ByteString
-> (([ByteString] -> [ByteString])
    -> ByteString -> IO ([ByteString] -> [ByteString]))
-> ([ByteString] -> [ByteString])
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), [ByteString] -> [ByteString])
forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound
                            ByteString
bound
                            ([ByteString] -> [ByteString])
-> ByteString -> IO ([ByteString] -> [ByteString])
forall {m :: * -> *} {a} {c}.
Monad m =>
([a] -> c) -> a -> m ([a] -> c)
iter
                            [ByteString] -> [ByteString]
forall a. a -> a
seed
                            Source
src
                            (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Maybe Int -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o)
                    let bs :: ByteString
bs = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
                    let x' :: (ByteString, ByteString)
x' = (ByteString
name, ByteString
bs)
                    let newParmSize :: Int
newParmSize = Int
parmSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                    case ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o of
                        Just Int
maxParmSize ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newParmSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxParmSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                RequestParseException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (RequestParseException -> IO ()) -> RequestParseException -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    Int -> RequestParseException
MaxParamSizeExceeded Int
newParmSize
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Either (ByteString, ByteString) (File y) -> IO ()
add (Either (ByteString, ByteString) (File y) -> IO ())
-> Either (ByteString, ByteString) (File y) -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString)
-> Either (ByteString, ByteString) (File y)
forall a b. a -> Either a b
Left (ByteString, ByteString)
x'
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Int -> Int -> Int64 -> Source -> IO ()
loop
                            (Int
numParms Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                            Int
numFiles
                            Int
newParmSize
                            Int64
filesSize
                            Source
src
                Maybe (Maybe ByteString, ByteString, Maybe ByteString)
_ -> do
                    -- ignore this part
                    let seed :: ()
seed = ()
                        iter :: () -> p -> m ()
iter () p
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    ((Bool
wasFound, Int64
_fileSize), ()) <- ByteString
-> (() -> ByteString -> IO ())
-> ()
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), ())
forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound () -> ByteString -> IO ()
forall {m :: * -> *} {p}. Monad m => () -> p -> m ()
iter ()
seed Source
src Maybe Int64
forall a. Maybe a
Nothing
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms Int
numFiles Int
parmSize Int64
filesSize Source
src
      where
        contDisp :: HeaderName
contDisp = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
S8.pack [Char]
"Content-Disposition"
        contType :: HeaderName
contType = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
S8.pack [Char]
"Content-Type"
        parsePair :: ByteString -> (HeaderName, ByteString)
parsePair ByteString
s =
            let (ByteString
x, ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
_colon ByteString
s
             in (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk ByteString
x, (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space) ByteString
y)

-- | Things that could go wrong while parsing a 'Request'
--
-- @since 3.1.15
data RequestParseException
    = MaxParamSizeExceeded Int
    | ParamNameTooLong S.ByteString Int
    | MaxFileNumberExceeded Int
    | FilenameTooLong S.ByteString Int
    | TooManyHeaderLines Int
    deriving (RequestParseException -> RequestParseException -> Bool
(RequestParseException -> RequestParseException -> Bool)
-> (RequestParseException -> RequestParseException -> Bool)
-> Eq RequestParseException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequestParseException -> RequestParseException -> Bool
== :: RequestParseException -> RequestParseException -> Bool
$c/= :: RequestParseException -> RequestParseException -> Bool
/= :: RequestParseException -> RequestParseException -> Bool
Eq, Typeable)

instance E.Exception RequestParseException
instance Show RequestParseException where
    show :: RequestParseException -> [Char]
show = \case
        MaxParamSizeExceeded Int
lmax -> [[Char]] -> [Char]
unwords [[Char]
"maximum parameter size exceeded:", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
lmax]
        ParamNameTooLong ByteString
s Int
lmax -> [[Char]] -> [Char]
unwords [[Char]
"parameter name", ByteString -> [Char]
S8.unpack ByteString
s, [Char]
"is too long:", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
lmax]
        MaxFileNumberExceeded Int
lmax -> [[Char]] -> [Char]
unwords [[Char]
"maximum number of files exceeded:", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
lmax]
        FilenameTooLong ByteString
fn Int
lmax ->
            [[Char]] -> [Char]
unwords [[Char]
"file name", ByteString -> [Char]
S8.unpack ByteString
fn, [Char]
"too long:", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
lmax]
        TooManyHeaderLines Int
nmax -> [[Char]] -> [Char]
unwords [[Char]
"Too many lines in mime/multipart header:", Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nmax]

data Bound
    = FoundBound S.ByteString S.ByteString
    | NoBound
    | PartialBound
    deriving (Bound -> Bound -> Bool
(Bound -> Bound -> Bool) -> (Bound -> Bound -> Bool) -> Eq Bound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bound -> Bound -> Bool
== :: Bound -> Bound -> Bool
$c/= :: Bound -> Bound -> Bool
/= :: Bound -> Bound -> Bool
Eq, Int -> Bound -> ShowS
[Bound] -> ShowS
Bound -> [Char]
(Int -> Bound -> ShowS)
-> (Bound -> [Char]) -> ([Bound] -> ShowS) -> Show Bound
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bound -> ShowS
showsPrec :: Int -> Bound -> ShowS
$cshow :: Bound -> [Char]
show :: Bound -> [Char]
$cshowList :: [Bound] -> ShowS
showList :: [Bound] -> ShowS
Show)

findBound :: S.ByteString -> S.ByteString -> Bound
findBound :: ByteString -> ByteString -> Bound
findBound ByteString
b ByteString
bs = (ByteString, ByteString) -> Bound
handleBreak ((ByteString, ByteString) -> Bound)
-> (ByteString, ByteString) -> Bound
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> (ByteString, ByteString)
S.breakSubstring ByteString
b ByteString
bs
  where
    handleBreak :: (ByteString, ByteString) -> Bound
handleBreak (ByteString
h, ByteString
t)
        | ByteString -> Bool
S.null ByteString
t = [Int] -> Bound
go [Int
lowBound .. ByteString -> Int
S.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        | Bool
otherwise = ByteString -> ByteString -> Bound
FoundBound ByteString
h (ByteString -> Bound) -> ByteString -> Bound
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
b) ByteString
t

    lowBound :: Int
lowBound = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
S.length ByteString
b

    go :: [Int] -> Bound
go [] = Bound
NoBound
    go (Int
i : [Int]
is)
        | [Int] -> [Int] -> Bool
mismatch [Int
0 .. ByteString -> Int
S.length ByteString
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Int
i .. ByteString -> Int
S.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] = [Int] -> Bound
go [Int]
is
        | Bool
otherwise =
            let endI :: Int
endI = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
b
             in if Int
endI Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ByteString -> Int
S.length ByteString
bs
                    then Bound
PartialBound
                    else ByteString -> ByteString -> Bound
FoundBound (Int -> ByteString -> ByteString
S.take Int
i ByteString
bs) (Int -> ByteString -> ByteString
S.drop Int
endI ByteString
bs)
    mismatch :: [Int] -> [Int] -> Bool
mismatch [] [Int]
_ = Bool
False
    mismatch [Int]
_ [] = Bool
False
    mismatch (Int
x : [Int]
xs) (Int
y : [Int]
ys)
        | HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
S.index ByteString
b Int
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
S.index ByteString
bs Int
y = [Int] -> [Int] -> Bool
mismatch [Int]
xs [Int]
ys
        | Bool
otherwise = Bool
True

sinkTillBound'
    :: S.ByteString
    -> S.ByteString
    -> FileInfo ()
    -> BackEnd y
    -> Source
    -> Maybe Int64
    -> IO ((Bool, Int64), y)
sinkTillBound' :: forall y.
ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
sinkTillBound' ByteString
bound ByteString
name FileInfo ()
fi BackEnd y
sink Source
src Maybe Int64
max' = do
    (IO ByteString
next, IO (Bool, Int64)
final) <- ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max'
    y
y <- BackEnd y
sink ByteString
name FileInfo ()
fi IO ByteString
next
    (Bool, Int64)
b <- IO (Bool, Int64)
final
    ((Bool, Int64), y) -> IO ((Bool, Int64), y)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Int64)
b, y
y)

data WTB
    = WTBWorking (S.ByteString -> S.ByteString)
    | WTBDone Bool
wrapTillBound
    :: S.ByteString
    -- ^ bound
    -> Source
    -> Maybe Int64
    -> IO (IO S.ByteString, IO (Bool, Int64))
    -- ^ Bool indicates if the bound was found
wrapTillBound :: ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max' = do
    IORef WTB
ref <- WTB -> IO (IORef WTB)
forall a. a -> IO (IORef a)
newIORef (WTB -> IO (IORef WTB)) -> WTB -> IO (IORef WTB)
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> WTB
WTBWorking ByteString -> ByteString
forall a. a -> a
id
    IORef Int64
sref <- Int64 -> IO (IORef Int64)
forall a. a -> IO (IORef a)
newIORef (Int64
0 :: Int64)
    (IO ByteString, IO (Bool, Int64))
-> IO (IO ByteString, IO (Bool, Int64))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref, IORef WTB -> IORef Int64 -> IO (Bool, Int64)
forall {b}. IORef WTB -> IORef b -> IO (Bool, b)
final IORef WTB
ref IORef Int64
sref)
  where
    final :: IORef WTB -> IORef b -> IO (Bool, b)
final IORef WTB
ref IORef b
sref = do
        WTB
x <- IORef WTB -> IO WTB
forall a. IORef a -> IO a
readIORef IORef WTB
ref
        case WTB
x of
            WTBWorking ByteString -> ByteString
_ -> [Char] -> IO (Bool, b)
forall a. HasCallStack => [Char] -> a
error [Char]
"wrapTillBound did not finish"
            WTBDone Bool
y -> do
                b
siz <- IORef b -> IO b
forall a. IORef a -> IO a
readIORef IORef b
sref
                (Bool, b) -> IO (Bool, b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
y, b
siz)

    go :: IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref = do
        WTB
state <- IORef WTB -> IO WTB
forall a. IORef a -> IO a
readIORef IORef WTB
ref
        case WTB
state of
            WTBDone Bool
_ -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty
            WTBWorking ByteString -> ByteString
front -> do
                ByteString
bs <- Source -> IO ByteString
readSource Source
src
                Int64
cur <- IORef Int64 -> (Int64 -> (Int64, Int64)) -> IO Int64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int64
sref ((Int64 -> (Int64, Int64)) -> IO Int64)
-> (Int64 -> (Int64, Int64)) -> IO Int64
forall a b. (a -> b) -> a -> b
$ \Int64
cur ->
                    let new :: Int64
new = Int64
cur Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
bs) in (Int64
new, Int64
new)
                case Maybe Int64
max' of
                    Just Int64
max'' | Int64
cur Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
max'' -> InvalidRequest -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO InvalidRequest
PayloadTooLarge
                    Maybe Int64
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                if ByteString -> Bool
S.null ByteString
bs
                    then do
                        IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WTB
WTBDone Bool
False
                        ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
front ByteString
bs
                    else ByteString -> IO ByteString
push (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
front ByteString
bs
      where
        push :: ByteString -> IO ByteString
push ByteString
bs = do
            case ByteString -> ByteString -> Bound
findBound ByteString
bound ByteString
bs of
                FoundBound ByteString
before ByteString
after -> do
                    let before' :: ByteString
before' = ByteString -> ByteString
killCRLF ByteString
before
                    Source -> ByteString -> IO ()
leftover Source
src ByteString
after
                    IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WTB
WTBDone Bool
True
                    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
before'
                Bound
NoBound -> do
                    -- don't emit newlines, in case it's part of a bound
                    let (ByteString
toEmit, ByteString -> ByteString
front') =
                            if Bool -> Bool
not (ByteString -> Bool
S8.null ByteString
bs) Bool -> Bool -> Bool
&& ByteString -> Char
S8.last ByteString
bs Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\r', Char
'\n']
                                then
                                    let (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt (ByteString -> Int
S.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) ByteString
bs
                                     in (ByteString
x, ByteString -> ByteString -> ByteString
S.append ByteString
y)
                                else (ByteString
bs, ByteString -> ByteString
forall a. a -> a
id)
                    IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> WTB
WTBWorking ByteString -> ByteString
front'
                    if ByteString -> Bool
S.null ByteString
toEmit
                        then IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref
                        else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
toEmit
                Bound
PartialBound -> do
                    IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> WTB
WTBWorking ((ByteString -> ByteString) -> WTB)
-> (ByteString -> ByteString) -> WTB
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
S.append ByteString
bs
                    IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref

sinkTillBound
    :: S.ByteString
    -> (x -> S.ByteString -> IO x)
    -> x
    -> Source
    -> Maybe Int64
    -> IO ((Bool, Int64), x)
sinkTillBound :: forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound x -> ByteString -> IO x
iter x
seed0 Source
src Maybe Int64
max' = do
    (IO ByteString
next, IO (Bool, Int64)
final) <- ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max'
    let loop :: x -> IO x
loop x
seed = do
            ByteString
bs <- IO ByteString
next
            if ByteString -> Bool
S.null ByteString
bs
                then x -> IO x
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return x
seed
                else x -> ByteString -> IO x
iter x
seed ByteString
bs IO x -> (x -> IO x) -> IO x
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= x -> IO x
loop
    x
seed <- x -> IO x
loop x
seed0
    (Bool, Int64)
b <- IO (Bool, Int64)
final
    ((Bool, Int64), x) -> IO ((Bool, Int64), x)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Int64)
b, x
seed)

parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
parseAttrs :: ByteString -> [(ByteString, ByteString)]
parseAttrs = (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ByteString, ByteString)
go ([ByteString] -> [(ByteString, ByteString)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
_semicolon
  where
    tw :: ByteString -> ByteString
tw = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space)
    dq :: ByteString -> ByteString
dq ByteString
s =
        if ByteString -> Int
S.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
S.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_quotedbl Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
S.last ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_quotedbl
            then HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init ByteString
s
            else ByteString
s
    go :: ByteString -> (ByteString, ByteString)
go ByteString
s =
        let (ByteString
x, ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
_equal ByteString
s
         in (ByteString -> ByteString
tw ByteString
x, ByteString -> ByteString
dq (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
tw ByteString
y)

killCRLF :: S.ByteString -> S.ByteString
killCRLF :: ByteString -> ByteString
killCRLF ByteString
bs
    | ByteString -> Bool
S.null ByteString
bs Bool -> Bool -> Bool
|| HasCallStack => ByteString -> Word8
ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_lf = ByteString
bs
    | Bool
otherwise = ByteString -> ByteString
killCR (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init ByteString
bs

killCR :: S.ByteString -> S.ByteString
killCR :: ByteString -> ByteString
killCR ByteString
bs
    | ByteString -> Bool
S.null ByteString
bs Bool -> Bool -> Bool
|| HasCallStack => ByteString -> Word8
ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_cr = ByteString
bs
    | Bool
otherwise = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init ByteString
bs