{-# 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 qualified Control.Exception as E
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S8
import Data.Word (Word8)
import Data.Int (Int64)
import Data.Maybe (catMaybes, fromMaybe)
import Data.List (sortBy)
import Data.Function (on, fix)
import System.Directory (removeFile, getTemporaryDirectory)
import System.IO (hClose, openBinaryTempFile)
import System.IO.Error (isDoesNotExistError)
import Network.Wai
import qualified Network.HTTP.Types as H
import Control.Applicative ((<$>))
import Control.Exception (catchJust)
import Control.Monad (when, unless, guard)
import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
import Data.IORef
import Network.HTTP.Types (hContentType)
import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
import Data.CaseInsensitive (mk)

import Prelude hiding (lines)

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
44 -- 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
0x3B ByteString
s
            stars :: Int
stars = Word8 -> ByteString -> Int
S.count Word8
0x2A 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
0x20) ByteString
s) -- 0x20 is space
            q' :: ByteString
q' = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word8
0x3B) (Int -> ByteString -> ByteString
S.drop Int
3 ByteString
q) -- 0x3B is semicolon
         in (ByteString
s', ByteString -> b
forall p. (Read p, Fractional p) => ByteString -> p
readQ ByteString
q')
    readQ :: ByteString -> p
readQ ByteString
s = case ReadS p
forall a. Read a => ReadS a
reads ReadS p -> ReadS p
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
S8.unpack ByteString
s of
                (p
x, [Char]
_):[(p, [Char])]
_ -> p
x
                [(p, [Char])]
_ -> p
1.0

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

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

-- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.
tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
                    -> String -- ^ filename pattern
                    -> InternalState
                    -> ignored1
                    -> ignored2
                    -> IO S.ByteString
                    -> IO FilePath
tempFileBackEndOpts :: IO [Char]
-> [Char]
-> InternalState
-> ignored1
-> ignored2
-> IO ByteString
-> IO [Char]
tempFileBackEndOpts IO [Char]
getTmpDir [Char]
pattrn InternalState
internalState ignored1
_ ignored2
_ IO ByteString
popper = do
    (ReleaseKey
key, ([Char]
fp, Handle
h)) <- (ResourceT IO (ReleaseKey, ([Char], Handle))
 -> InternalState -> IO (ReleaseKey, ([Char], Handle)))
-> InternalState
-> ResourceT IO (ReleaseKey, ([Char], Handle))
-> IO (ReleaseKey, ([Char], Handle))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResourceT IO (ReleaseKey, ([Char], Handle))
-> InternalState -> IO (ReleaseKey, ([Char], Handle))
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState InternalState
internalState (ResourceT IO (ReleaseKey, ([Char], Handle))
 -> IO (ReleaseKey, ([Char], Handle)))
-> ResourceT IO (ReleaseKey, ([Char], Handle))
-> IO (ReleaseKey, ([Char], Handle))
forall a b. (a -> b) -> a -> b
$ IO ([Char], Handle)
-> (([Char], Handle) -> IO ())
-> ResourceT IO (ReleaseKey, ([Char], Handle))
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO ([Char], Handle)
it (Handle -> IO ()
hClose (Handle -> IO ())
-> (([Char], Handle) -> Handle) -> ([Char], Handle) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Handle) -> Handle
forall a b. (a, b) -> b
snd)
    ReleaseKey
_ <- ResourceT IO ReleaseKey -> InternalState -> IO ReleaseKey
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState (IO () -> ResourceT IO ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> ResourceT IO ReleaseKey)
-> IO () -> ResourceT IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFileQuiet [Char]
fp) InternalState
internalState
    (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
        ByteString
bs <- IO ByteString
popper
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Handle -> ByteString -> IO ()
S.hPut Handle
h ByteString
bs
            IO ()
loop
    ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
key
    [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
fp
    where
        it :: IO ([Char], Handle)
it = do
            [Char]
tempDir <- IO [Char]
getTmpDir
            [Char] -> [Char] -> IO ([Char], Handle)
openBinaryTempFile [Char]
tempDir [Char]
pattrn
        removeFileQuiet :: [Char] -> IO ()
removeFileQuiet [Char]
fp = (IOError -> Maybe ()) -> IO () -> (() -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
                                       ([Char] -> IO ()
removeFile [Char]
fp)
                                       (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (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=Int -> Maybe Int
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=Maybe Int
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=Int -> Maybe Int
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=Maybe Int
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=Int64 -> Maybe Int64
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=Maybe Int64
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=Int64 -> Maybe Int64
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=Maybe Int64
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=Int -> Maybe Int
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=Maybe Int
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=Int -> Maybe Int
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=Maybe Int
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=Int -> Maybe Int
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=Maybe Int
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 :: Maybe Int
-> Maybe Int
-> Maybe Int64
-> Maybe Int64
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> ParseRequestBodyOptions
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 :: Maybe Int
-> Maybe Int
-> Maybe Int64
-> Maybe Int64
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> ParseRequestBodyOptions
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
    { FileInfo c -> ByteString
fileName :: S.ByteString
    , FileInfo c -> ByteString
fileContentType :: S.ByteString
    , 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
/= :: 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
[FileInfo c] -> ShowS
FileInfo c -> [Char]
(Int -> FileInfo c -> ShowS)
-> (FileInfo c -> [Char])
-> ([FileInfo c] -> ShowS)
-> Show (FileInfo c)
forall c. Show c => Int -> FileInfo c -> ShowS
forall c. Show c => [FileInfo c] -> ShowS
forall c. Show c => FileInfo c -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FileInfo c] -> ShowS
$cshowList :: forall c. Show c => [FileInfo c] -> ShowS
show :: FileInfo c -> [Char]
$cshow :: forall c. Show c => FileInfo c -> [Char]
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' <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
    let (ByteString
ctype, [(ByteString, ByteString)]
attrs) = ByteString -> (ByteString, [(ByteString, ByteString)])
parseContentType ByteString
ctype'
    case ByteString
ctype of
        ByteString
"application/x-www-form-urlencoded" -> RequestBodyType -> Maybe RequestBodyType
forall (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 (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)]
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
    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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& ByteString -> Word8
S.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34 Bool -> Bool -> Bool
&& ByteString -> Word8
S.last ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34 -- quote
                then ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ 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 (Word8 -> Word8 -> Bool
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 ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> [(ByteString, ByteString)]
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 -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
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
equals) 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.
parseRequestBody :: BackEnd y
                 -> Request
                 -> IO ([Param], [File y])
parseRequestBody :: 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.
parseRequestBodyEx :: ParseRequestBodyOptions
                   -> BackEnd y
                   -> Request
                   -> IO ([Param], [File y])
parseRequestBodyEx :: 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 (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
requestBody Request
r)

sinkRequestBody :: BackEnd y
                -> RequestBodyType
                -> IO S.ByteString
                -> IO ([Param], [File y])
sinkRequestBody :: 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

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

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


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

    close :: ByteString -> IO (Maybe ByteString)
close ByteString
front = Source -> ByteString -> IO ()
leftover Source
src ByteString
front IO () -> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ByteString -> IO (Maybe ByteString)
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
10) ByteString
bs -- LF
         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
$
                          HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError (ErrorCode -> ErrorCodeId
UnknownErrorCode ErrorCode
431)
                                    ByteString
"Request Header Fields Too Large"
                        Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
killCR (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ 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 =
    [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

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 (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
$
                [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Too many lines in mime/multipart header"
        Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe ByteString
res <- Maybe Int -> Source -> IO (Maybe ByteString)
takeLine Maybe Int
lineLength Source
src
    case Maybe ByteString
res of
        Maybe ByteString
Nothing -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
lines
        Just ByteString
l
            | ByteString -> Bool
S.null ByteString
l -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
lines
            | Bool
otherwise -> [ByteString] -> Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines'' (ByteString
lByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
lines) Maybe Int
lineLength Maybe Int
maxLines Source
src

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

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

readSource :: Source -> IO S.ByteString
readSource :: Source -> IO ByteString
readSource (Source IO ByteString
f IORef ByteString
ref) = do
    ByteString
bs <- IORef ByteString
-> (ByteString -> (ByteString, ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ByteString
ref ((ByteString -> (ByteString, ByteString)) -> IO ByteString)
-> (ByteString -> (ByteString, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> (ByteString
S.empty, ByteString
bs)
    if ByteString -> Bool
S.null ByteString
bs
        then IO ByteString
f
        else ByteString -> IO ByteString
forall (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) ByteString
bs = IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
ref ByteString
bs

parsePiecesEx :: ParseRequestBodyOptions
              -> BackEnd y
              -> S.ByteString
              -> IO S.ByteString
              -> (Either Param (File y) -> IO ())
              -> IO ()
parsePiecesEx :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
0 Int
0 Int
0 Int64
0
  where
    loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
    loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms Int
numFiles Int
parmSize Int64
filesSize Source
src = do
        Maybe ByteString
_boundLine <- Maybe Int -> Source -> IO (Maybe ByteString)
takeLine (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength ParseRequestBodyOptions
o) Source
src
        [ByteString]
res' <- Maybe Int -> Maybe Int -> Source -> IO [ByteString]
takeLines' (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLineLength ParseRequestBodyOptions
o)
            (ParseRequestBodyOptions -> Maybe Int
prboMaxHeaderLines ParseRequestBodyOptions
o) Source
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
res') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let ls' :: [(HeaderName, ByteString)]
ls' = (ByteString -> (HeaderName, ByteString))
-> [ByteString] -> [(HeaderName, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (HeaderName, ByteString)
parsePair [ByteString]
res'
            let x :: Maybe (Maybe ByteString, ByteString, Maybe ByteString)
x = do
                    ByteString
cd <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contDisp [(HeaderName, ByteString)]
ls'
                    let ct :: Maybe ByteString
ct = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
contType [(HeaderName, ByteString)]
ls'
                    let attrs :: [(ByteString, ByteString)]
attrs = ByteString -> [(ByteString, ByteString)]
parseAttrs ByteString
cd
                    ByteString
name <- ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"name" [(ByteString, ByteString)]
attrs
                    (Maybe ByteString, ByteString, Maybe ByteString)
-> Maybe (Maybe ByteString, ByteString, Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
ct, ByteString
name, ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"filename" [(ByteString, ByteString)]
attrs)
            case Maybe (Maybe ByteString, ByteString, Maybe ByteString)
x of
                Just (Maybe ByteString
mct, ByteString
name, Just ByteString
filename) -> do
                    case ParseRequestBodyOptions -> Maybe Int
prboKeyLength ParseRequestBodyOptions
o of
                        Just Int
maxKeyLength ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxKeyLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Filename is too long"
                        Maybe Int
Nothing -> () -> IO ()
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
$
                            [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Maximum number of files exceeded"
                        Maybe Int
Nothing -> () -> IO ()
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]
fs [Int64] -> [Int64] -> Bool
forall a. Eq a => a -> a -> Bool
== [] 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 (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int64]
fs
                    ((Bool
wasFound, Int64
fileSize), y
y) <- ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
forall y.
ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
sinkTillBound' ByteString
bound ByteString
name FileInfo ()
fi0 BackEnd y
sink Source
src Maybe Int64
mfs
                    let newFilesSize :: Int64
newFilesSize = Int64
filesSize Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
fileSize
                    Either (ByteString, ByteString) (File y) -> IO ()
add (Either (ByteString, ByteString) (File y) -> IO ())
-> Either (ByteString, ByteString) (File y) -> IO ()
forall a b. (a -> b) -> a -> b
$ File y -> Either (ByteString, ByteString) (File y)
forall a b. b -> Either a b
Right (ByteString
name, FileInfo ()
fi0 { fileContent :: y
fileContent = y
y })
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms (Int
numFiles Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
parmSize Int64
newFilesSize Source
src
                Just (Maybe ByteString
_ct, ByteString
name, Maybe ByteString
Nothing) -> do
                    case ParseRequestBodyOptions -> Maybe Int
prboKeyLength ParseRequestBodyOptions
o of
                        Just Int
maxKeyLength ->
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxKeyLength) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Parameter name is too long"
                        Maybe Int
Nothing -> () -> IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return (([a] -> c) -> m ([a] -> c)) -> ([a] -> c) -> m ([a] -> c)
forall a b. (a -> b) -> a -> b
$ [a] -> c
front ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) a
bs
                    ((Bool
wasFound, Int64
_fileSize), [ByteString] -> [ByteString]
front) <- ByteString
-> (([ByteString] -> [ByteString])
    -> ByteString -> IO ([ByteString] -> [ByteString]))
-> ([ByteString] -> [ByteString])
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), [ByteString] -> [ByteString])
forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound ([ByteString] -> [ByteString])
-> ByteString -> IO ([ByteString] -> [ByteString])
forall (m :: * -> *) a c.
Monad m =>
([a] -> c) -> a -> m ([a] -> c)
iter [ByteString] -> [ByteString]
forall a. a -> a
seed Source
src
                        (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Maybe Int -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o)
                    let bs :: ByteString
bs = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
front []
                    let x' :: (ByteString, ByteString)
x' = (ByteString
name, ByteString
bs)
                    let newParmSize :: Int
newParmSize = Int
parmSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                    case ParseRequestBodyOptions -> Maybe Int
prboMaxParmsSize ParseRequestBodyOptions
o of
                        Just Int
maxParmSize -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newParmSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxParmSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Maximum size of parameters exceeded"
                        Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Either (ByteString, ByteString) (File y) -> IO ()
add (Either (ByteString, ByteString) (File y) -> IO ())
-> Either (ByteString, ByteString) (File y) -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString)
-> Either (ByteString, ByteString) (File y)
forall a b. a -> Either a b
Left (ByteString, ByteString)
x'
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop (Int
numParms Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
numFiles
                        Int
newParmSize Int64
filesSize Source
src
                Maybe (Maybe ByteString, ByteString, Maybe ByteString)
_ -> do
                    -- ignore this part
                    let seed :: ()
seed = ()
                        iter :: () -> p -> m ()
iter () p
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    ((Bool
wasFound, Int64
_fileSize), ()) <- ByteString
-> (() -> ByteString -> IO ())
-> ()
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), ())
forall x.
ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound () -> ByteString -> IO ()
forall (m :: * -> *) p. Monad m => () -> p -> m ()
iter ()
seed Source
src Maybe Int64
forall a. Maybe a
Nothing
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasFound (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int64 -> Source -> IO ()
loop Int
numParms Int
numFiles Int
parmSize Int64
filesSize Source
src
      where
        contDisp :: HeaderName
contDisp = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
S8.pack [Char]
"Content-Disposition"
        contType :: HeaderName
contType = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
S8.pack [Char]
"Content-Type"
        parsePair :: ByteString -> (HeaderName, ByteString)
parsePair ByteString
s =
            let (ByteString
x, ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
58 ByteString
s -- colon
             in (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ ByteString
x, (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
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
(Bound -> Bound -> Bool) -> (Bound -> Bound -> Bool) -> Eq Bound
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 -> [Char]
(Int -> Bound -> ShowS)
-> (Bound -> [Char]) -> ([Bound] -> ShowS) -> Show Bound
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Bound] -> ShowS
$cshowList :: [Bound] -> ShowS
show :: Bound -> [Char]
$cshow :: Bound -> [Char]
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 ((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)
        | ByteString -> Int -> Word8
S.index ByteString
b Int
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 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' :: ByteString
-> ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
sinkTillBound' ByteString
bound ByteString
name FileInfo ()
fi BackEnd y
sink Source
src Maybe Int64
max' = do
    (IO ByteString
next, IO (Bool, Int64)
final) <- ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max'
    y
y <- BackEnd y
sink ByteString
name FileInfo ()
fi IO ByteString
next
    (Bool, Int64)
b <- IO (Bool, Int64)
final
    ((Bool, Int64), y) -> IO ((Bool, Int64), y)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Int64)
b, y
y)

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

    go :: IORef WTB -> IORef Int64 -> IO ByteString
go IORef WTB
ref IORef Int64
sref = do
        WTB
state <- IORef WTB -> IO WTB
forall a. IORef a -> IO a
readIORef IORef WTB
ref
        case WTB
state of
            WTBDone Bool
_ -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty
            WTBWorking ByteString -> ByteString
front -> do
                ByteString
bs <- Source -> IO ByteString
readSource Source
src
                Int64
cur <- IORef Int64 -> (Int64 -> (Int64, Int64)) -> IO Int64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int64
sref ((Int64 -> (Int64, Int64)) -> IO Int64)
-> (Int64 -> (Int64, Int64)) -> IO Int64
forall a b. (a -> b) -> a -> b
$ \ Int64
cur ->
                    let new :: Int64
new = Int64
cur Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
bs) in (Int64
new, Int64
new)
                case Maybe Int64
max' of
                   Just Int64
max'' | Int64
cur Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
max'' ->
                     HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError (ErrorCode -> ErrorCodeId
UnknownErrorCode ErrorCode
413) ByteString
"Payload Too Large"
                   Maybe Int64
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                if ByteString -> Bool
S.null ByteString
bs
                    then do
                        IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WTB
WTBDone Bool
False
                        ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
front ByteString
bs
                    else ByteString -> IO ByteString
push (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
front ByteString
bs
      where
        push :: ByteString -> IO ByteString
push ByteString
bs = do
            case ByteString -> ByteString -> Bound
findBound ByteString
bound ByteString
bs of
                FoundBound ByteString
before ByteString
after -> do
                    let before' :: ByteString
before' = ByteString -> ByteString
killCRLF ByteString
before
                    Source -> ByteString -> IO ()
leftover Source
src ByteString
after
                    IORef WTB -> WTB -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WTB
ref (WTB -> IO ()) -> WTB -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WTB
WTBDone Bool
True
                    ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
before'
                Bound
NoBound -> do
                    -- don't emit newlines, in case it's part of a bound
                    let (ByteString
toEmit, ByteString -> ByteString
front') =
                            if Bool -> Bool
not (ByteString -> Bool
S8.null ByteString
bs) Bool -> Bool -> Bool
&& ByteString -> Char
S8.last ByteString
bs Char -> [Char] -> Bool
forall (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 (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 :: ByteString
-> (x -> ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound ByteString
bound x -> ByteString -> IO x
iter x
seed0 Source
src Maybe Int64
max' = do
    (IO ByteString
next, IO (Bool, Int64)
final) <- ByteString
-> Source -> Maybe Int64 -> IO (IO ByteString, IO (Bool, Int64))
wrapTillBound ByteString
bound Source
src Maybe Int64
max'
    let loop :: x -> IO x
loop x
seed = do
            ByteString
bs <- IO ByteString
next
            if ByteString -> Bool
S.null ByteString
bs
                then x -> IO x
forall (m :: * -> *) a. Monad m => a -> m a
return x
seed
                else x -> ByteString -> IO x
iter x
seed ByteString
bs IO x -> (x -> IO x) -> IO x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= x -> IO x
loop
    x
seed <- x -> IO x
loop x
seed0
    (Bool, Int64)
b <- IO (Bool, Int64)
final
    ((Bool, Int64), x) -> IO ((Bool, Int64), x)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Int64)
b, x
seed)

parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
parseAttrs :: ByteString -> [(ByteString, ByteString)]
parseAttrs = (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ByteString, ByteString)
go ([ByteString] -> [(ByteString, ByteString)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
59 -- semicolon
  where
    tw :: ByteString -> ByteString
tw = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32) -- 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
&& ByteString -> Word8
S.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34 Bool -> Bool -> Bool
&& ByteString -> Word8
S.last ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34 -- quote
                then ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ 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 (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
|| ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
10 = ByteString
bs -- line feed
    | Bool
otherwise = ByteString -> ByteString
killCR (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ 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
|| ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
13 = ByteString
bs -- carriage return
    | Bool
otherwise = ByteString -> ByteString
S.init ByteString
bs