wai-extra-3.1.14: Network/Wai/Parse.hs
{-# LANGUAGE CPP #-}
{-# language DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# language LambdaCase #-}
{-# 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
, RequestParseException(..)
, BackEnd
, lbsBackEnd
, tempFileBackEnd
, tempFileBackEndOpts
, Param
, File
, FileInfo (..)
, parseContentType
, ParseRequestBodyOptions
, defaultParseRequestBodyOptions
, noLimitParseRequestBodyOptions
, parseRequestBodyEx
, setMaxRequestKeyLength
, clearMaxRequestKeyLength
, setMaxRequestNumFiles
, clearMaxRequestNumFiles
, setMaxRequestFileSize
, clearMaxRequestFileSize
, setMaxRequestFilesSize
, clearMaxRequestFilesSize
, setMaxRequestParmsSize
, clearMaxRequestParmsSize
, setMaxHeaderLines
, clearMaxHeaderLines
, setMaxHeaderLineLength
, clearMaxHeaderLineLength
#if TEST
, Bound (..)
, findBound
, sinkTillBound
, killCR
, killCRLF
, takeLine
#endif
) where
import Prelude hiding (lines)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import 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 Data.Bifunctor (bimap)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Function (fix, on)
import Data.IORef
import Data.Int (Int64)
import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Typeable
import Data.Word8
import Network.HTTP.Types (hContentType)
import qualified Network.HTTP.Types as H
import Network.Wai
import Network.Wai.Handler.Warp (InvalidRequest(..))
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (hClose, openBinaryTempFile)
import System.IO.Error (isDoesNotExistError)
breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
breakDiscard w s =
let (x, y) = S.break (== w) s
in (x, S.drop 1 y)
-- | Parse the HTTP accept string to determine supported content types.
parseHttpAccept :: S.ByteString -> [S.ByteString]
parseHttpAccept = map fst
. sortBy (rcompare `on` snd)
. map (addSpecificity . grabQ)
. S.split _comma
where
rcompare :: (Double,Int) -> (Double,Int) -> Ordering
rcompare = flip compare
addSpecificity (s, q) =
-- Prefer higher-specificity types
let semicolons = S.count _semicolon s
stars = S.count _asterisk s
in (s, (q, semicolons - stars))
grabQ s =
-- Stripping all spaces may be too harsh.
-- Maybe just strip either side of semicolon?
let (s', q) = S.breakSubstring ";q=" (S.filter (/= _space) s)
q' = S.takeWhile (/= _semicolon) (S.drop 3 q)
in (s', readQ q')
readQ s = case reads $ S8.unpack s of
(x, _):_ -> x
_ -> 1.0
-- | Store uploaded files in memory
lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString
lbsBackEnd _ _ popper =
loop id
where
loop front = do
bs <- popper
if S.null bs
then return $ L.fromChunks $ front []
else loop $ front . (bs:)
-- | Save uploaded files on disk as temporary files
--
-- Note: starting with version 2.0, removal of temp files is registered with
-- the provided @InternalState@. It is the responsibility of the caller to
-- ensure that this @InternalState@ gets cleaned up.
tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "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 getTmpDir pattrn internalState _ _ popper = do
(key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
_ <- runInternalState (register $ removeFileQuiet fp) internalState
fix $ \loop -> do
bs <- popper
unless (S.null bs) $ do
S.hPut h bs
loop
release key
return fp
where
it = do
tempDir <- getTmpDir
openBinaryTempFile tempDir pattrn
removeFileQuiet fp = catchJust (guard . isDoesNotExistError)
(removeFile fp)
(const $ 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
prboKeyLength :: Maybe Int
, -- | The maximum number of files.
prboMaxNumFiles :: Maybe Int
, -- | The maximum filesize per file.
prboMaxFileSize :: Maybe Int64
, -- | The maximum total filesize.
prboMaxFilesSize :: Maybe Int64
, -- | The maximum size of the sum of all parameters
prboMaxParmsSize :: Maybe Int
, -- | The maximum header lines per mime/multipart entry
prboMaxHeaderLines :: Maybe Int
, -- | The maximum header line length per mime/multipart entry
prboMaxHeaderLineLength :: Maybe Int }
-- | Set the maximum length of a filename.
--
-- @since 3.0.16.0
setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestKeyLength l p = p { prboKeyLength=Just l }
-- | Do not limit the length of filenames.
--
-- @since 3.0.16.0
clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestKeyLength p = p { prboKeyLength=Nothing }
-- | Set the maximum number of files per request.
--
-- @since 3.0.16.0
setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l }
-- | Do not limit the maximum number of files per request.
--
-- @since 3.0.16.0
clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing }
-- | Set the maximum filesize per file (in bytes).
--
-- @since 3.0.16.0
setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFileSize l p = p { prboMaxFileSize=Just l }
-- | Do not limit the maximum filesize per file.
--
-- @since 3.0.16.0
clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing }
-- | Set the maximum size of all files per request.
--
-- @since 3.0.16.0
setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l }
-- | Do not limit the maximum size of all files per request.
--
-- @since 3.0.16.0
clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing }
-- | Set the maximum size of the sum of all parameters.
--
-- @since 3.0.16.0
setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l }
-- | Do not limit the maximum size of the sum of all parameters.
--
-- @since 3.0.16.0
clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing }
-- | Set the maximum header lines per mime/multipart entry.
--
-- @since 3.0.16.0
setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l }
-- | Do not limit the maximum header lines per mime/multipart entry.
--
-- @since 3.0.16.0
clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing }
-- | Set the maximum header line length per mime/multipart entry.
--
-- @since 3.0.16.0
setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l }
-- | Do not limit the maximum header lines per mime/multipart entry.
--
-- @since 3.0.16.0
clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }
-- | A reasonable default set of parsing options.
-- Maximum key/filename length: 32 bytes;
-- maximum files: 10; filesize unlimited; maximum
-- size for parameters: 64kbytes; maximum number of header
-- lines: 32 bytes (applies only to headers of a mime/multipart message);
-- maximum header line length: Apache's default for that is 8190 bytes
-- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline)
-- so we're using that here as well.
--
-- @since 3.0.16.0
defaultParseRequestBodyOptions :: ParseRequestBodyOptions
defaultParseRequestBodyOptions = ParseRequestBodyOptions
{ prboKeyLength=Just 32
, prboMaxNumFiles=Just 10
, prboMaxFileSize=Nothing
, prboMaxFilesSize=Nothing
, prboMaxParmsSize=Just 65336
, prboMaxHeaderLines=Just 32
, prboMaxHeaderLineLength=Just 8190 }
-- | Do not impose any memory limits.
--
-- @since 3.0.21.0
noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
noLimitParseRequestBodyOptions = ParseRequestBodyOptions
{ prboKeyLength=Nothing
, prboMaxNumFiles=Nothing
, prboMaxFileSize=Nothing
, prboMaxFilesSize=Nothing
, prboMaxParmsSize=Nothing
, prboMaxHeaderLines=Nothing
, prboMaxHeaderLineLength=Nothing }
-- | Information on an uploaded file.
data FileInfo c = FileInfo
{ fileName :: S.ByteString
, fileContentType :: S.ByteString
, fileContent :: c
}
deriving (Eq, 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 req = do
ctype' <- lookup hContentType $ requestHeaders req
let (ctype, attrs) = parseContentType ctype'
case ctype of
"application/x-www-form-urlencoded" -> return UrlEncoded
"multipart/form-data" | Just bound <- lookup "boundary" attrs -> return $ Multipart bound
_ -> 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 a = do
let (ctype, b) = S.break (== _semicolon) a
attrs = goAttrs id $ S.drop 1 b
in (ctype, attrs)
where
dq s = if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl
then S.tail $ S.init s
else s
goAttrs front bs
| S.null bs = front []
| otherwise =
let (x, rest) = S.break (== _semicolon) bs
in goAttrs (front . (goAttr x:)) $ S.drop 1 rest
goAttr bs =
let (k, v') = S.break (== _equal) bs
v = S.drop 1 v'
in (strip k, dq $ strip v)
strip = S.dropWhile (== _space) . fst . S.breakEnd (/= _space)
-- | Parse the body of an HTTP request.
-- See parseRequestBodyEx for details.
-- Note: This function does not limit the memory it allocates.
-- When dealing with untrusted data (as is usually the case when
-- receiving input from the internet), it is recommended to
-- use the 'parseRequestBodyEx' function instead.
--
-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
parseRequestBody :: BackEnd y
-> Request
-> IO ([Param], [File y])
parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions
-- | Parse the body of an HTTP request, limit resource usage.
-- The HTTP body can contain both parameters and files.
-- This function will return a list of key,value pairs
-- for all parameters, and a list of key,a pairs
-- for filenames. The a depends on the used backend that
-- is responsible for storing the received files.
--
-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
parseRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> Request
-> IO ([Param], [File y])
parseRequestBodyEx o s r =
case getRequestBodyType r of
Nothing -> return ([], [])
Just rbt -> sinkRequestBodyEx o s rbt (getRequestBodyChunk r)
-- | since 3.1.15 : throws 'RequestParseException' if something goes wrong
sinkRequestBody :: BackEnd y
-> RequestBodyType
-> IO S.ByteString
-> IO ([Param], [File y])
sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
-- | Throws 'RequestParseException' if something goes wrong
--
-- @since 3.0.16.0
--
-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
sinkRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO S.ByteString
-> IO ([Param], [File y])
sinkRequestBodyEx o s r body = do
ref <- newIORef ([], [])
let add x = atomicModifyIORef ref $ \(y, z) ->
case x of
Left y' -> ((y':y, z), ())
Right z' -> ((y, z':z), ())
conduitRequestBodyEx o s r body add
bimap reverse reverse <$> readIORef ref
conduitRequestBodyEx :: ParseRequestBodyOptions
-> BackEnd y
-> RequestBodyType
-> IO S.ByteString
-> (Either Param (File y) -> IO ())
-> IO ()
conduitRequestBodyEx o _ UrlEncoded rbody 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 size front = do
bs <- rbody
if S.null bs
then return $ S.concat $ front []
else do
let newsize = size + S.length bs
case prboMaxParmsSize o of
Just maxSize -> when (newsize > maxSize) $
E.throwIO $ MaxParamSizeExceeded newsize
Nothing -> return ()
loop newsize $ front . (bs:)
bs <- loop 0 id
mapM_ (add . Left) $ H.parseSimpleQuery bs
conduitRequestBodyEx o backend (Multipart bound) rbody add =
parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody 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 maxlen src =
go ""
where
go front = do
bs <- readSource src
case maxlen of
Just maxlen' -> when (S.length front > maxlen') $
E.throwIO RequestHeaderFieldsTooLarge
Nothing -> return ()
if S.null bs
then close front
else push front bs
close front = leftover src front >> return Nothing
push front bs = do
let (x, y) = S.break (== _lf) bs
in if S.null y
then go $ front `S.append` x
else do
when (S.length y > 1) $ leftover src $ S.drop 1 y
let res = front `S.append` x
case maxlen of
Just maxlen' -> when (S.length res > maxlen') $
E.throwIO RequestHeaderFieldsTooLarge
Nothing -> return ()
return . Just $ killCR res
-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
takeLines' lineLength maxLines source =
reverse <$> takeLines'' [] lineLength maxLines source
-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
takeLines''
:: [S.ByteString]
-> Maybe Int
-> Maybe Int
-> Source
-> IO [S.ByteString]
takeLines'' lines lineLength maxLines src = do
case maxLines of
Just maxLines' ->
when (length lines > maxLines') $
E.throwIO $ TooManyHeaderLines (length lines)
Nothing -> return ()
res <- takeLine lineLength src
case res of
Nothing -> return lines
Just l
| S.null l -> return lines
| otherwise -> takeLines'' (l:lines) lineLength maxLines src
data Source = Source (IO S.ByteString) (IORef S.ByteString)
mkSource :: IO S.ByteString -> IO Source
mkSource f = do
ref <- newIORef S.empty
return $ Source f ref
readSource :: Source -> IO S.ByteString
readSource (Source f ref) = do
bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs)
if S.null bs
then f
else return bs
{- HLint ignore readSource "Use tuple-section" -}
leftover :: Source -> S.ByteString -> IO ()
leftover (Source _ ref) = writeIORef ref
-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
parsePiecesEx :: ParseRequestBodyOptions
-> BackEnd y
-> S.ByteString
-> IO S.ByteString
-> (Either Param (File y) -> IO ())
-> IO ()
parsePiecesEx o sink bound rbody add =
mkSource rbody >>= loop 0 0 0 0
where
loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
loop numParms numFiles parmSize filesSize src = do
_boundLine <- takeLine (prboMaxHeaderLineLength o) src
res' <- takeLines' (prboMaxHeaderLineLength o)
(prboMaxHeaderLines o) src
unless (null res') $ do
let ls' = map parsePair res'
let x = do
cd <- lookup contDisp ls'
let ct = lookup contType ls'
let attrs = parseAttrs cd
name <- lookup "name" attrs
return (ct, name, lookup "filename" attrs)
case x of
Just (mct, name, Just filename) -> do
case prboKeyLength o of
Just maxKeyLength ->
when (S.length name > maxKeyLength) $
E.throwIO $ FilenameTooLong name maxKeyLength
Nothing -> return ()
case prboMaxNumFiles o of
Just maxFiles -> when (numFiles >= maxFiles) $
E.throwIO $ MaxFileNumberExceeded numFiles
Nothing -> return ()
let ct = fromMaybe "application/octet-stream" mct
fi0 = FileInfo filename ct ()
fs = catMaybes [ prboMaxFileSize o
, subtract filesSize <$> prboMaxFilesSize o ]
mfs = if null fs then Nothing else Just $ minimum fs
((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
let newFilesSize = filesSize + fileSize
add $ Right (name, fi0 { fileContent = y })
when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
Just (_ct, name, Nothing) -> do
case prboKeyLength o of
Just maxKeyLength ->
when (S.length name > maxKeyLength) $
E.throwIO $ ParamNameTooLong name maxKeyLength
Nothing -> return ()
let seed = id
let iter front bs = return $ front . (:) bs
((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src
(fromIntegral <$> prboMaxParmsSize o)
let bs = S.concat $ front []
let x' = (name, bs)
let newParmSize = parmSize + S.length name + S.length bs
case prboMaxParmsSize o of
Just maxParmSize -> when (newParmSize > maxParmSize) $
E.throwIO $ MaxParamSizeExceeded newParmSize
Nothing -> return ()
add $ Left x'
when wasFound $ loop (numParms + 1) numFiles
newParmSize filesSize src
_ -> do
-- ignore this part
let seed = ()
iter () _ = return ()
((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
when wasFound $ loop numParms numFiles parmSize filesSize src
where
contDisp = mk $ S8.pack "Content-Disposition"
contType = mk $ S8.pack "Content-Type"
parsePair s =
let (x, y) = breakDiscard _colon s
in (mk x, S.dropWhile (== _space) y)
-- | Things that could go wrong while parsing a 'Request'
--
-- @since 3.1.15
data RequestParseException = MaxParamSizeExceeded Int
| ParamNameTooLong S.ByteString Int
| MaxFileNumberExceeded Int
| FilenameTooLong S.ByteString Int
| TooManyHeaderLines Int
deriving (Eq, Typeable)
instance E.Exception RequestParseException
instance Show RequestParseException where
show = \case
MaxParamSizeExceeded lmax -> unwords ["maximum parameter size exceeded:", show lmax]
ParamNameTooLong s lmax -> unwords ["parameter name", S8.unpack s, "is too long:", show lmax]
MaxFileNumberExceeded lmax -> unwords ["maximum number of files exceeded:", show lmax]
FilenameTooLong fn lmax ->
unwords ["file name", S8.unpack fn, "too long:", show lmax]
TooManyHeaderLines nmax -> unwords ["Too many lines in mime/multipart header:", show nmax]
data Bound = FoundBound S.ByteString S.ByteString
| NoBound
| PartialBound
deriving (Eq, Show)
findBound :: S.ByteString -> S.ByteString -> Bound
findBound b bs = handleBreak $ S.breakSubstring b bs
where
handleBreak (h, t)
| S.null t = go [lowBound..S.length bs - 1]
| otherwise = FoundBound h $ S.drop (S.length b) t
lowBound = max 0 $ S.length bs - S.length b
go [] = NoBound
go (i:is)
| mismatch [0..S.length b - 1] [i..S.length bs - 1] = go is
| otherwise =
let endI = i + S.length b
in if endI > S.length bs
then PartialBound
else FoundBound (S.take i bs) (S.drop endI bs)
mismatch [] _ = False
mismatch _ [] = False
mismatch (x:xs) (y:ys)
| S.index b x == S.index bs y = mismatch xs ys
| otherwise = True
sinkTillBound' :: S.ByteString
-> S.ByteString
-> FileInfo ()
-> BackEnd y
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), y)
sinkTillBound' bound name fi sink src max' = do
(next, final) <- wrapTillBound bound src max'
y <- sink name fi next
b <- final
return (b, y)
data WTB = WTBWorking (S.ByteString -> S.ByteString)
| WTBDone Bool
wrapTillBound :: S.ByteString -- ^ bound
-> Source
-> Maybe Int64
-> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found
wrapTillBound bound src max' = do
ref <- newIORef $ WTBWorking id
sref <- newIORef (0 :: Int64)
return (go ref sref, final ref sref)
where
final ref sref = do
x <- readIORef ref
case x of
WTBWorking _ -> error "wrapTillBound did not finish"
WTBDone y -> do
siz <- readIORef sref
return (y, siz)
go ref sref = do
state <- readIORef ref
case state of
WTBDone _ -> return S.empty
WTBWorking front -> do
bs <- readSource src
cur <- atomicModifyIORef' sref $ \ cur ->
let new = cur + fromIntegral (S.length bs) in (new, new)
case max' of
Just max'' | cur > max'' -> E.throwIO PayloadTooLarge
_ -> return ()
if S.null bs
then do
writeIORef ref $ WTBDone False
return $ front bs
else push $ front bs
where
push bs = do
case findBound bound bs of
FoundBound before after -> do
let before' = killCRLF before
leftover src after
writeIORef ref $ WTBDone True
return before'
NoBound -> do
-- don't emit newlines, in case it's part of a bound
let (toEmit, front') =
if not (S8.null bs) && S8.last bs `elem` ['\r','\n']
then let (x, y) = S.splitAt (S.length bs - 2) bs
in (x, S.append y)
else (bs, id)
writeIORef ref $ WTBWorking front'
if S.null toEmit
then go ref sref
else return toEmit
PartialBound -> do
writeIORef ref $ WTBWorking $ S.append bs
go ref sref
sinkTillBound :: S.ByteString
-> (x -> S.ByteString -> IO x)
-> x
-> Source
-> Maybe Int64
-> IO ((Bool, Int64), x)
sinkTillBound bound iter seed0 src max' = do
(next, final) <- wrapTillBound bound src max'
let loop seed = do
bs <- next
if S.null bs
then return seed
else iter seed bs >>= loop
seed <- loop seed0
b <- final
return (b, seed)
parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
parseAttrs = map go . S.split _semicolon
where
tw = S.dropWhile (== _space)
dq s = if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl
then S.tail $ S.init s
else s
go s =
let (x, y) = breakDiscard _equal s
in (tw x, dq $ tw y)
killCRLF :: S.ByteString -> S.ByteString
killCRLF bs
| S.null bs || S.last bs /= _lf = bs
| otherwise = killCR $ S.init bs
killCR :: S.ByteString -> S.ByteString
killCR bs
| S.null bs || S.last bs /= _cr = bs
| otherwise = S.init bs