{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
-- | Some helpers for parsing data out of a raw WAI 'Request'.

module Network.Wai.Parse
    ( parseHttpAccept
    , parseRequestBody
    , RequestBodyType (..)
    , getRequestBodyType
    , sinkRequestBody
    , sinkRequestBodyEx
    , 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 Data.CaseInsensitive (mk)
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 qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Function (fix, on)
import Data.IORef
import Data.Int (Int64)
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Word (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 (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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Double, Int) -> (Double, Int) -> Ordering
rcompare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. (ByteString, a) -> (ByteString, (a, Int))
addSpecificity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. (Read b, Fractional b) => ByteString -> (ByteString, b)
grabQ)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
44 -- comma
  where
    rcompare :: (Double,Int) -> (Double,Int) -> Ordering
    rcompare :: (Double, Int) -> (Double, Int) -> Ordering
rcompare = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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
0x3B ByteString
s
            stars :: Int
stars = Word8 -> ByteString -> Int
S.count Word8
0x2A ByteString
s
        in (ByteString
s, (a
q, Int
semicolons 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 (forall a. Eq a => a -> a -> Bool
/=Word8
0x20) ByteString
s) -- 0x20 is space
            q' :: ByteString
q' = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/=Word8
0x3B) (Int -> ByteString -> ByteString
S.drop Int
3 ByteString
q) -- 0x3B is semicolon
         in (ByteString
s', forall {a}. (Read a, Fractional a) => ByteString -> a
readQ ByteString
q')
    readQ :: ByteString -> a
readQ ByteString
s = case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ ByteString -> String
S8.unpack ByteString
s of
                (a
x, String
_):[(a, String)]
_ -> a
x
                [(a, String)]
_ -> 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 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
            else ([ByteString] -> [ByteString]) -> m ByteString
loop forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsforall 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 String
tempFileBackEnd = forall ignored1 ignored2.
IO String
-> String
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO String
tempFileBackEndOpts IO String
getTemporaryDirectory String
"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 String
-> String
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO String
tempFileBackEndOpts IO String
getTmpDir String
pattrn InternalState
internalState ignored1
_ ignored2
_ IO ByteString
popper = do
    (ReleaseKey
key, (String
fp, Handle
h)) <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState InternalState
internalState forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO (String, Handle)
it (Handle -> IO ()
hClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
    ReleaseKey
_ <- forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState (forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFileQuiet String
fp) InternalState
internalState
    forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
        ByteString
bs <- IO ByteString
popper
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
            Handle -> ByteString -> IO ()
S.hPut Handle
h ByteString
bs
            IO ()
loop
    forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
key
    forall (m :: * -> *) a. Monad m => a -> m a
return String
fp
    where
        it :: IO (String, Handle)
it = do
            String
tempDir <- IO String
getTmpDir
            String -> String -> IO (String, Handle)
openBinaryTempFile String
tempDir String
pattrn
        removeFileQuiet :: String -> IO ()
removeFileQuiet String
fp = forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
                                       (String -> IO ()
removeFile String
fp)
                                       (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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
    { -- | The maximum length of a filename
      ParseRequestBodyOptions -> Maybe Int
prboKeyLength             :: Maybe Int
    , -- | The maximum number of files.
      ParseRequestBodyOptions -> Maybe Int
prboMaxNumFiles           :: Maybe Int
    , -- | The maximum filesize per file.
      ParseRequestBodyOptions -> Maybe Int64
prboMaxFileSize           :: Maybe Int64
    , -- | The maximum total filesize.
      ParseRequestBodyOptions -> Maybe Int64
prboMaxFilesSize          :: Maybe Int64
    , -- | The maximum size of the sum of all parameters
      ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize          :: Maybe Int
    , -- | The maximum header lines per mime/multipart entry
      ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLines        :: Maybe Int
    , -- | The maximum header line length per mime/multipart entry
      ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength   :: Maybe Int }

-- | 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 :: Maybe Int
prboKeyLength=forall a. a -> Maybe a
Just Int
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 :: Maybe Int
prboKeyLength=forall a. Maybe a
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 :: Maybe Int
prboMaxNumFiles=forall a. a -> Maybe a
Just Int
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 :: Maybe Int
prboMaxNumFiles=forall a. Maybe a
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 :: Maybe Int64
prboMaxFileSize=forall a. a -> Maybe a
Just Int64
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 :: Maybe Int64
prboMaxFileSize=forall a. Maybe a
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 :: Maybe Int64
prboMaxFilesSize=forall a. a -> Maybe a
Just Int64
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 :: Maybe Int64
prboMaxFilesSize=forall a. Maybe a
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 :: Maybe Int
prboMaxParmsSize=forall a. a -> Maybe a
Just Int
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 :: Maybe Int
prboMaxParmsSize=forall a. Maybe a
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 :: Maybe Int
prboMaxHeaderLines=forall a. a -> Maybe a
Just Int
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 :: Maybe Int
prboMaxHeaderLines=forall a. Maybe a
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 :: Maybe Int
prboMaxHeaderLineLength=forall a. a -> Maybe a
Just Int
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 :: Maybe Int
prboMaxHeaderLineLength=forall a. Maybe a
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=forall a. a -> Maybe a
Just Int
32
    , prboMaxNumFiles :: Maybe Int
prboMaxNumFiles=forall a. a -> Maybe a
Just Int
10
    , prboMaxFileSize :: Maybe Int64
prboMaxFileSize=forall a. Maybe a
Nothing
    , prboMaxFilesSize :: Maybe Int64
prboMaxFilesSize=forall a. Maybe a
Nothing
    , prboMaxParmsSize :: Maybe Int
prboMaxParmsSize=forall a. a -> Maybe a
Just Int
65336
    , prboMaxHeaderLines :: Maybe Int
prboMaxHeaderLines=forall a. a -> Maybe a
Just Int
32
    , prboMaxHeaderLineLength :: Maybe Int
prboMaxHeaderLineLength=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=forall a. Maybe a
Nothing
    , prboMaxNumFiles :: Maybe Int
prboMaxNumFiles=forall a. Maybe a
Nothing
    , prboMaxFileSize :: Maybe Int64
prboMaxFileSize=forall a. Maybe a
Nothing
    , prboMaxFilesSize :: Maybe Int64
prboMaxFilesSize=forall a. Maybe a
Nothing
    , prboMaxParmsSize :: Maybe Int
prboMaxParmsSize=forall a. Maybe a
Nothing
    , prboMaxHeaderLines :: Maybe Int
prboMaxHeaderLines=forall a. Maybe a
Nothing
    , prboMaxHeaderLineLength :: Maybe Int
prboMaxHeaderLineLength=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
forall c. Eq c => FileInfo c -> FileInfo c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileInfo c -> FileInfo c -> Bool
$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
Eq, Int -> FileInfo c -> ShowS
forall c. Show c => Int -> FileInfo c -> ShowS
forall c. Show c => [FileInfo c] -> ShowS
forall c. Show c => FileInfo c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileInfo c] -> ShowS
$cshowList :: forall c. Show c => [FileInfo c] -> ShowS
show :: FileInfo c -> String
$cshow :: forall c. Show c => FileInfo c -> String
showsPrec :: Int -> FileInfo c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> 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' <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
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" -> forall (m :: * -> *) a. Monad m => a -> m a
return RequestBodyType
UrlEncoded
        ByteString
"multipart/form-data" | Just ByteString
bound <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"boundary" [(ByteString, ByteString)]
attrs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> RequestBodyType
Multipart ByteString
bound
        ByteString
_ -> 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 (forall a. Eq a => a -> a -> Bool
== Word8
semicolon) ByteString
a
        attrs :: [(ByteString, ByteString)]
attrs = ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
goAttrs forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
b
     in (ByteString
ctype, [(ByteString, ByteString)]
attrs)
  where
    semicolon :: Word8
semicolon = Word8
59
    equals :: Word8
equals = Word8
61
    space :: Word8
space = Word8
32
    dq :: ByteString -> ByteString
dq ByteString
s = if ByteString -> Int
S.length ByteString
s forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
S.head ByteString
s forall a. Eq a => a -> a -> Bool
== Word8
34 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
S.last ByteString
s forall a. Eq a => a -> a -> Bool
== Word8
34 -- quote
                then HasCallStack => ByteString -> ByteString
S.tail forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
S.init ByteString
s
                else ByteString
s
    goAttrs :: ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
goAttrs [(ByteString, ByteString)] -> [(ByteString, ByteString)]
front ByteString
bs
        | ByteString -> Bool
S.null ByteString
bs = [(ByteString, ByteString)] -> [(ByteString, ByteString)]
front []
        | Bool
otherwise =
            let (ByteString
x, ByteString
rest) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (forall a. Eq a => a -> a -> Bool
== Word8
semicolon) ByteString
bs
             in ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
goAttrs ([(ByteString, ByteString)] -> [(ByteString, ByteString)]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> (ByteString, ByteString)
goAttr ByteString
xforall a. a -> [a] -> [a]
:)) 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 (forall a. Eq a => a -> a -> Bool
== Word8
equals) ByteString
bs
            v :: ByteString
v = Int -> ByteString -> ByteString
S.drop Int
1 ByteString
v'
         in (ByteString -> ByteString
strip ByteString
k, ByteString -> ByteString
dq forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
strip ByteString
v)
    strip :: ByteString -> ByteString
strip = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (forall a. Eq a => a -> a -> Bool
== Word8
space) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.breakEnd (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.
parseRequestBody :: BackEnd y
                 -> Request
                 -> IO ([Param], [File y])
parseRequestBody :: forall y.
BackEnd y -> Request -> IO ([(ByteString, ByteString)], [File y])
parseRequestBody = 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.
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
        Just RequestBodyType
rbt -> forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBodyEx ParseRequestBodyOptions
o BackEnd y
s RequestBodyType
rbt (Request -> IO ByteString
requestBody Request
r)

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 = forall y.
ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO ByteString
-> IO ([(ByteString, ByteString)], [File y])
sinkRequestBodyEx ParseRequestBodyOptions
noLimitParseRequestBodyOptions

-- |
--
-- @since 3.0.16.0
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 <- forall a. a -> IO (IORef a)
newIORef ([], [])
    let add :: Either (ByteString, ByteString) (File y) -> IO ()
add Either (ByteString, ByteString) (File y)
x = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ([(ByteString, ByteString)], [File y])
ref 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'forall a. a -> [a] -> [a]
:[(ByteString, ByteString)]
y, [File y]
z), ())
                Right File y
z' -> (([(ByteString, ByteString)]
y, File y
z'forall a. a -> [a] -> [a]
:[File y]
z), ())
    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)]
a, [File y]
b) -> (forall a. [a] -> [a]
reverse [(ByteString, ByteString)]
a, forall a. [a] -> [a]
reverse [File y]
b)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
                else do
                    let newsize :: Int
newsize = Int
size forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                    case ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o of
                        Just Int
maxSize -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newsize forall a. Ord a => a -> a -> Bool
> Int
maxSize) forall a b. (a -> b) -> a -> b
$
                            forall a. HasCallStack => String -> a
error String
"Maximum size of parameters exceeded"
                        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
newsize forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsforall a. a -> [a] -> [a]
:)
    ByteString
bs <- Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
0 forall a. a -> a
id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Either (ByteString, ByteString) (File y) -> IO ()
add forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) 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 =
    forall y.
ParseRequestBodyOptions
-> BackEnd y
-> ByteString
-> IO ByteString
-> (Either (ByteString, ByteString) (File y) -> IO ())
-> IO ()
parsePiecesEx ParseRequestBodyOptions
o BackEnd y
backend (String -> ByteString
S8.pack String
"--" 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' -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
front forall a. Ord a => a -> a -> Bool
> Int
maxlen') forall a b. (a -> b) -> a -> b
$
              forall e a. Exception e => e -> IO a
E.throwIO InvalidRequest
RequestHeaderFieldsTooLarge
            Maybe Int
Nothing -> 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a. Eq a => a -> a -> Bool
== Word8
10) ByteString
bs -- LF
         in if ByteString -> Bool
S.null ByteString
y
                then ByteString -> IO (Maybe ByteString)
go forall a b. (a -> b) -> a -> b
$ ByteString
front ByteString -> ByteString -> ByteString
`S.append` ByteString
x
                else do
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
y forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ Source -> ByteString -> IO ()
leftover Source
src 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' -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
res forall a. Ord a => a -> a -> Bool
> Int
maxlen') forall a b. (a -> b) -> a -> b
$
                          forall e a. Exception e => e -> IO a
E.throwIO InvalidRequest
RequestHeaderFieldsTooLarge
                        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
killCR ByteString
res

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 =
    forall a. [a] -> [a]
reverse 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

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' ->
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
lines forall a. Ord a => a -> a -> Bool
> Int
maxLines') forall a b. (a -> b) -> a -> b
$
                forall a. HasCallStack => String -> a
error String
"Too many lines in mime/multipart header"
        Maybe Int
Nothing -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
lines
        Just ByteString
l
            | ByteString -> Bool
S.null ByteString
l -> forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
lines
            | Bool
otherwise -> [ByteString] -> Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'' (ByteString
lforall 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 <- forall a. a -> IO (IORef a)
newIORef ByteString
S.empty
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ByteString
ref 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 forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

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

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 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
res') forall a b. (a -> b) -> a -> b
$ do
            let ls' :: RequestHeaders
ls' = 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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contDisp RequestHeaders
ls'
                    let ct :: Maybe ByteString
ct = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contType RequestHeaders
ls'
                    let attrs :: [(ByteString, ByteString)]
attrs = ByteString -> [(ByteString, ByteString)]
parseAttrs ByteString
cd
                    ByteString
name <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"name" [(ByteString, ByteString)]
attrs
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
ct, ByteString
name, 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 ->
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
name forall a. Ord a => a -> a -> Bool
> Int
maxKeyLength) forall a b. (a -> b) -> a -> b
$
                                forall a. HasCallStack => String -> a
error String
"Filename is too long"
                        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    case ParseRequestBodyOptions -> Maybe Int
prboMaxNumFiles ParseRequestBodyOptions
o of
                        Just Int
maxFiles -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numFiles forall a. Ord a => a -> a -> Bool
>= Int
maxFiles) forall a b. (a -> b) -> a -> b
$
                            forall a. HasCallStack => String -> a
error String
"Maximum number of files exceeded"
                        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    let ct :: ByteString
ct = forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octet-stream" Maybe ByteString
mct
                        fi0 :: FileInfo ()
fi0 = forall c. ByteString -> ByteString -> c -> FileInfo c
FileInfo ByteString
filename ByteString
ct ()
                        fs :: [Int64]
fs = forall a. [Maybe a] -> [a]
catMaybes [ ParseRequestBodyOptions -> Maybe Int64
prboMaxFileSize ParseRequestBodyOptions
o
                                       , forall a. Num a => a -> a -> a
subtract Int64
filesSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseRequestBodyOptions -> Maybe Int64
prboMaxFilesSize ParseRequestBodyOptions
o ]
                        mfs :: Maybe Int64
mfs = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int64]
fs then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int64]
fs
                    ((Bool
wasFound, Int64
fileSize), y
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 forall a. Num a => a -> a -> a
+ Int64
fileSize
                    Either (ByteString, ByteString) (File y) -> IO ()
add forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (ByteString
name, FileInfo ()
fi0 { fileContent :: y
fileContent = y
y })
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms (Int
numFiles 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 ->
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
name forall a. Ord a => a -> a -> Bool
> Int
maxKeyLength) forall a b. (a -> b) -> a -> b
$
                                forall a. HasCallStack => String -> a
error String
"Parameter name is too long"
                        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    let seed :: a -> a
seed = forall a. a -> a
id
                    let iter :: ([a] -> c) -> a -> m ([a] -> c)
iter [a] -> c
front a
bs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a] -> c
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) a
bs
                    ((Bool
wasFound, Int64
_fileSize), [ByteString] -> [ByteString]
front) <- forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound forall {m :: * -> *} {a} {c}.
Monad m =>
([a] -> c) -> a -> m ([a] -> c)
iter forall a. a -> a
seed Source
src
                        (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 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 forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
name forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                    case ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o of
                        Just Int
maxParmSize -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newParmSize forall a. Ord a => a -> a -> Bool
> Int
maxParmSize) forall a b. (a -> b) -> a -> b
$
                            forall a. HasCallStack => String -> a
error String
"Maximum size of parameters exceeded"
                        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Either (ByteString, ByteString) (File y) -> IO ()
add forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (ByteString, ByteString)
x'
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop (Int
numParms 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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    ((Bool
wasFound, Int64
_fileSize), ()) <- forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound forall {m :: * -> *} {p}. Monad m => () -> p -> m ()
iter ()
seed Source
src forall a. Maybe a
Nothing
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound 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 = forall s. FoldCase s => s -> CI s
mk forall a b. (a -> b) -> a -> b
$ String -> ByteString
S8.pack String
"Content-Disposition"
        contType :: HeaderName
contType = forall s. FoldCase s => s -> CI s
mk forall a b. (a -> b) -> a -> b
$ String -> ByteString
S8.pack String
"Content-Type"
        parsePair :: ByteString -> (HeaderName, ByteString)
parsePair ByteString
s =
            let (ByteString
x, ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
58 ByteString
s -- colon
             in (forall s. FoldCase s => s -> CI s
mk ByteString
x, (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (forall a. Eq a => a -> a -> Bool
== Word8
32) ByteString
y) -- space


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

findBound :: S.ByteString -> S.ByteString -> Bound
findBound :: ByteString -> ByteString -> Bound
findBound ByteString
b ByteString
bs = (ByteString, ByteString) -> Bound
handleBreak 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 forall a. Num a => a -> a -> a
- Int
1]
        | Bool
otherwise = ByteString -> ByteString -> Bound
FoundBound ByteString
h forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
b) ByteString
t

    lowBound :: Int
lowBound = forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs 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 forall a. Num a => a -> a -> a
- Int
1] [Int
i..ByteString -> Int
S.length ByteString
bs forall a. Num a => a -> a -> a
- Int
1] = [Int] -> Bound
go [Int]
is
        | Bool
otherwise =
            let endI :: Int
endI = Int
i forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
b
             in if Int
endI 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
S.index ByteString
b Int
x forall a. Eq a => a -> a -> Bool
== HasCallStack => 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
    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 <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> WTB
WTBWorking forall a. a -> a
id
    IORef Int64
sref <- forall a. a -> IO (IORef a)
newIORef (Int64
0 :: Int64)
    forall (m :: * -> *) a. Monad m => a -> m a
return (IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref, 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 <- forall a. IORef a -> IO a
readIORef IORef WTB
ref
        case WTB
x of
            WTBWorking ByteString -> ByteString
_ -> forall a. HasCallStack => String -> a
error String
"wrapTillBound did not finish"
            WTBDone Bool
y -> do
                b
siz <- forall a. IORef a -> IO a
readIORef IORef b
sref
                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 <- forall a. IORef a -> IO a
readIORef IORef WTB
ref
        case WTB
state of
            WTBDone Bool
_ -> 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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int64
sref forall a b. (a -> b) -> a -> b
$ \ Int64
cur ->
                    let new :: Int64
new = Int64
cur forall a. Num a => a -> a -> a
+ 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 forall a. Ord a => a -> a -> Bool
> Int64
max'' -> forall e a. Exception e => e -> IO a
E.throwIO InvalidRequest
PayloadTooLarge
                   Maybe Int64
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                if ByteString -> Bool
S.null ByteString
bs
                    then do
                        forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref forall a b. (a -> b) -> a -> b
$ Bool -> WTB
WTBDone Bool
False
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
front ByteString
bs
                    else ByteString -> IO ByteString
push 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
                    forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref forall a b. (a -> b) -> a -> b
$ Bool -> WTB
WTBDone Bool
True
                    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 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 forall a. Num a => a -> a -> a
- Int
2) ByteString
bs
                                      in (ByteString
x, ByteString -> ByteString -> ByteString
S.append ByteString
y)
                                else (ByteString
bs, forall a. a -> a
id)
                    forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref 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 forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
toEmit
                Bound
PartialBound -> do
                    forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> WTB
WTBWorking 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 forall (m :: * -> *) a. Monad m => a -> m a
return x
seed
                else x -> ByteString -> IO x
iter x
seed ByteString
bs 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
    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 = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ByteString, ByteString)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
59 -- semicolon
  where
    tw :: ByteString -> ByteString
tw = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (forall a. Eq a => a -> a -> Bool
== Word8
32) -- space
    dq :: ByteString -> ByteString
dq ByteString
s = if ByteString -> Int
S.length ByteString
s forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
S.head ByteString
s forall a. Eq a => a -> a -> Bool
== Word8
34 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
S.last ByteString
s forall a. Eq a => a -> a -> Bool
== Word8
34 -- quote
                then HasCallStack => ByteString -> ByteString
S.tail forall a b. (a -> b) -> a -> b
$ HasCallStack => 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
61 ByteString
s -- equals sign
         in (ByteString -> ByteString
tw ByteString
x, ByteString -> ByteString
dq 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
S.last ByteString
bs forall a. Eq a => a -> a -> Bool
/= Word8
10 = ByteString
bs -- line feed
    | Bool
otherwise = ByteString -> ByteString
killCR forall a b. (a -> b) -> a -> b
$ HasCallStack => 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
S.last ByteString
bs forall a. Eq a => a -> a -> Bool
/= Word8
13 = ByteString
bs -- carriage return
    | Bool
otherwise = HasCallStack => ByteString -> ByteString
S.init ByteString
bs