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

module Network.Wai.Parse
    ( parseHttpAccept
    , parseRequestBody
    , RequestBodyType (..)
    , getRequestBodyType
    , sinkRequestBody
    , sinkRequestBodyEx
    , BackEnd
    , lbsBackEnd
    , tempFileBackEnd
    , tempFileBackEndOpts
    , Param
    , File
    , FileInfo (..)
    , parseContentType
    , ParseRequestBodyOptions
    , defaultParseRequestBodyOptions
    , noLimitParseRequestBodyOptions
    , parseRequestBodyEx
    , setMaxRequestKeyLength
    , clearMaxRequestKeyLength
    , setMaxRequestNumFiles
    , clearMaxRequestNumFiles
    , setMaxRequestFileSize
    , clearMaxRequestFileSize
    , setMaxRequestFilesSize
    , clearMaxRequestFilesSize
    , setMaxRequestParmsSize
    , clearMaxRequestParmsSize
    , setMaxHeaderLines
    , clearMaxHeaderLines
    , setMaxHeaderLineLength
    , clearMaxHeaderLineLength
#if TEST
    , Bound (..)
    , findBound
    , sinkTillBound
    , killCR
    , killCRLF
    , takeLine
#endif
    ) where

import Prelude hiding (lines)

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

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))
-> (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

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) = IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
ref

parsePiecesEx :: ParseRequestBodyOptions
              -> BackEnd y
              -> S.ByteString
              -> IO S.ByteString
              -> (Either Param (File y) -> IO ())
              -> IO ()
parsePiecesEx :: 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] -> 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 (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
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