{-# 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 -> 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 [ByteString] -> [ByteString]
forall a. a -> a
id
  where
    loop :: ([ByteString] -> [ByteString]) -> m ByteString
loop [ByteString] -> [ByteString]
front = do
        bs <- m ByteString
popper
        if S.null bs
            then return $ L.fromChunks $ front []
            else loop $ front . (bs :)

-- | 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 = IO String
-> String
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO String
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
    (key, (fp, h)) <-
        (ResourceT IO (ReleaseKey, (String, Handle))
 -> InternalState -> IO (ReleaseKey, (String, Handle)))
-> InternalState
-> ResourceT IO (ReleaseKey, (String, Handle))
-> IO (ReleaseKey, (String, Handle))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResourceT IO (ReleaseKey, (String, Handle))
-> InternalState -> IO (ReleaseKey, (String, Handle))
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState InternalState
internalState (ResourceT IO (ReleaseKey, (String, Handle))
 -> IO (ReleaseKey, (String, Handle)))
-> ResourceT IO (ReleaseKey, (String, Handle))
-> IO (ReleaseKey, (String, Handle))
forall a b. (a -> b) -> a -> b
$ IO (String, Handle)
-> ((String, Handle) -> IO ())
-> ResourceT IO (ReleaseKey, (String, Handle))
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO (String, Handle)
it (Handle -> IO ()
hClose (Handle -> IO ())
-> ((String, Handle) -> Handle) -> (String, Handle) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Handle) -> Handle
forall a b. (a, b) -> b
snd)
    _ <- runInternalState (register $ removeFileQuiet fp) internalState
    fix $ \IO ()
loop -> do
        bs <- IO ByteString
popper
        unless (S.null bs) $ do
            S.hPut h bs
            loop
    release key
    return fp
  where
    it :: IO (String, Handle)
it = do
        tempDir <- IO String
getTmpDir
        openBinaryTempFile tempDir pattrn
    removeFileQuiet :: String -> IO ()
removeFileQuiet String
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)
            (String -> IO ()
removeFile String
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 -> String
(Int -> FileInfo c -> ShowS)
-> (FileInfo c -> String)
-> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
show :: FileInfo c -> String
$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
    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 (ctype, attrs) = parseContentType ctype'
    case 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
    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)
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), ())
    conduitRequestBodyEx o s r body add
    bimap reverse reverse <$> readIORef 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
            bs <- IO ByteString
rbody
            if S.null bs
                then return $ S.concat $ front []
                else do
                    let newsize = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                    case prboMaxParmsSize 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. (HasCallStack, 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 ()
                    loop newsize $ front . (bs :)
    bs <- Int -> ([ByteString] -> [ByteString]) -> IO ByteString
loop Int
0 [ByteString] -> [ByteString]
forall a. a -> a
id
    mapM_ (add . Left) $ H.parseSimpleQuery 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 (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
        bs <- Source -> IO ByteString
readSource Source
src
        case 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. (HasCallStack, 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 S.null bs
            then close front
            else push front 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. (HasCallStack, 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. (HasCallStack, 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 ()
    res <- Maybe Int -> Source -> IO (Maybe ByteString)
takeLine Maybe Int
lineLength Source
src
    case 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
    ref <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
S.empty
    return $ Source f ref

readSource :: Source -> IO S.ByteString
readSource :: Source -> IO ByteString
readSource (Source IO ByteString
f IORef ByteString
ref) = do
    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 S.null bs
        then f
        else return 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
        _boundLine <- Maybe Int -> Source -> IO (Maybe ByteString)
takeLine (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength ParseRequestBodyOptions
o) Source
src
        res' <-
            takeLines'
                (prboMaxHeaderLineLength o)
                (prboMaxHeaderLines o)
                src
        unless (null res') $ do
            let ls' = (ByteString -> (HeaderName, ByteString))
-> [ByteString] -> [(HeaderName, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (HeaderName, ByteString)
parsePair [ByteString]
res'
            let x = do
                    cd <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contDisp [(HeaderName, ByteString)]
ls'
                    let 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, ByteString)]
parseAttrs ByteString
cd
                    name <- lookup "name" attrs
                    return (ct, name, lookup "filename" attrs)
            case 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. (HasCallStack, 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. (HasCallStack, 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
                    ((wasFound, fileSize), 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
filesSize Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
fileSize
                    add $ Right (name, fi0{fileContent = y})
                    when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize 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. (HasCallStack, 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
                    ((wasFound, _fileSize), 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] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
                    let x' = (ByteString
name, ByteString
bs)
                    let 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 prboMaxParmsSize 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. (HasCallStack, 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 ()
                    add $ Left x'
                    when wasFound $
                        loop
                            (numParms + 1)
                            numFiles
                            newParmSize
                            filesSize
                            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 ()
                    ((wasFound, _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
                    when wasFound $ loop numParms numFiles parmSize filesSize 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
$ String -> ByteString
S8.pack String
"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
$ 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
_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 -> String
show = \case
        MaxParamSizeExceeded Int
lmax -> [String] -> String
unwords [String
"maximum parameter size exceeded:", Int -> String
forall a. Show a => a -> String
show Int
lmax]
        ParamNameTooLong ByteString
s Int
lmax -> [String] -> String
unwords [String
"parameter name", ByteString -> String
S8.unpack ByteString
s, String
"is too long:", Int -> String
forall a. Show a => a -> String
show Int
lmax]
        MaxFileNumberExceeded Int
lmax -> [String] -> String
unwords [String
"maximum number of files exceeded:", Int -> String
forall a. Show a => a -> String
show Int
lmax]
        FilenameTooLong ByteString
fn Int
lmax ->
            [String] -> String
unwords [String
"file name", ByteString -> String
S8.unpack ByteString
fn, String
"too long:", Int -> String
forall a. Show a => a -> String
show Int
lmax]
        TooManyHeaderLines Int
nmax -> [String] -> String
unwords [String
"Too many lines in mime/multipart header:", Int -> String
forall a. Show a => a -> String
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 -> String
(Int -> Bound -> ShowS)
-> (Bound -> String) -> ([Bound] -> ShowS) -> Show Bound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bound -> ShowS
showsPrec :: Int -> Bound -> ShowS
$cshow :: Bound -> String
show :: Bound -> String
$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
    (next, final) <- ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max'
    y <- sink name fi next
    b <- final
    return (b, 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
    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
    sref <- newIORef (0 :: Int64)
    return (go ref sref, final ref sref)
  where
    final :: IORef WTB -> IORef b -> IO (Bool, b)
final IORef WTB
ref IORef b
sref = do
        x <- IORef WTB -> IO WTB
forall a. IORef a -> IO a
readIORef IORef WTB
ref
        case x of
            WTBWorking ByteString -> ByteString
_ -> String -> IO (Bool, b)
forall a. HasCallStack => String -> a
error String
"wrapTillBound did not finish"
            WTBDone Bool
y -> do
                siz <- IORef b -> IO b
forall a. IORef a -> IO a
readIORef IORef b
sref
                return (y, siz)

    go :: IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref = do
        state <- IORef WTB -> IO WTB
forall a. IORef a -> IO a
readIORef IORef WTB
ref
        case 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
                bs <- Source -> IO ByteString
readSource Source
src
                cur <- atomicModifyIORef' sref $ \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 max' of
                    Just Int64
max'' | Int64
cur Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
max'' -> InvalidRequest -> IO ()
forall e a. (HasCallStack, 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 S.null bs
                    then do
                        writeIORef ref $ WTBDone False
                        return $ front bs
                    else push $ front 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 -> String -> 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
    (next, final) <- ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max'
    let loop x
seed = do
            bs <- IO ByteString
next
            if S.null bs
                then return seed
                else iter seed bs >>= loop
    seed <- loop seed0
    b <- final
    return (b, 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