@@ -11,6 +11,7 @@ module Network.Wai.Parse
1111 , RequestBodyType (..)
1212 , getRequestBodyType
1313 , sinkRequestBody
14+ , sinkRequestBodyEx
1415 , BackEnd
1516 , lbsBackEnd
1617 , tempFileBackEnd
@@ -19,6 +20,24 @@ module Network.Wai.Parse
1920 , File
2021 , FileInfo (..)
2122 , parseContentType
23+ , ParseRequestBodyOptions
24+ , defaultParseRequestBodyOptions
25+ , noLimitParseRequestBodyOptions
26+ , parseRequestBodyEx
27+ , setMaxRequestKeyLength
28+ , clearMaxRequestKeyLength
29+ , setMaxRequestNumFiles
30+ , clearMaxRequestNumFiles
31+ , setMaxRequestFileSize
32+ , clearMaxRequestFileSize
33+ , setMaxRequestFilesSize
34+ , clearMaxRequestFilesSize
35+ , setMaxRequestParmsSize
36+ , clearMaxRequestParmsSize
37+ , setMaxHeaderLines
38+ , clearMaxHeaderLines
39+ , setMaxHeaderLineLength
40+ , clearMaxHeaderLineLength
2241#if TEST
2342 , Bound (..)
2443 , findBound
@@ -29,22 +48,30 @@ module Network.Wai.Parse
2948#endif
3049 ) where
3150
32−import qualified Data.ByteString.Search as Search
51+import qualified Control.Exception as E
3352import qualified Data.ByteString as S
3453import qualified Data.ByteString.Lazy as L
3554import qualified Data.ByteString.Char8 as S8
3655import Data.Word (Word8)
37−import Data.Maybe (fromMaybe)
56+import Data.Int (Int64)
57+import Data.Maybe (catMaybes, fromMaybe)
3858import Data.List (sortBy)
3959import Data.Function (on, fix)
4060import System.Directory (removeFile, getTemporaryDirectory)
4161import System.IO (hClose, openBinaryTempFile)
62+import System.IO.Error (isDoesNotExistError)
4263import Network.Wai
4364import qualified Network.HTTP.Types as H
44−import Control.Monad (when, unless)
65+import Control.Applicative ((<$>))
66+import Control.Exception (catchJust)
67+import Control.Monad (when, unless, guard)
4568import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
4669import Data.IORef
4770import Network.HTTP.Types (hContentType)
71+import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
72+import Data.CaseInsensitive (mk)
73+
74+import Prelude hiding (lines)
4875
4976breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
5077breakDiscard w s =
@@ -94,7 +121,7 @@ lbsBackEnd _ _ popper =
94121tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
95122tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"
96123
97−-- | Same as 'tempFileSink', but use configurable temp folders and patterns.
124+-- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.
98125tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
99126 -> String -- ^ filename pattern
100127 -> InternalState
@@ -102,11 +129,9 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
102129 -> ignored2
103130 -> IO S.ByteString
104131 -> IO FilePath
105−tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
106− (key, (fp, h)) <- flip runInternalState internalState $ allocate (do
107− tempDir <- getTmpDir
108− openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)
109− _ <- runInternalState (register $ removeFile fp) internalState
132+tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
133+ (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
134+ _ <- runInternalState (register $ removeFileQuiet fp) internalState
110135 fix $ \loop -> do
111136 bs <- popper
112137 unless (S.null bs) $ do
@@ -114,6 +139,150 @@ tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
114139 loop
115140 release key
116141 return fp
142+ where
143+ it = do
144+ tempDir <- getTmpDir
145+ openBinaryTempFile tempDir pattrn
146+ removeFileQuiet fp = catchJust (guard . isDoesNotExistError)
147+ (removeFile fp)
148+ (const $ return ())
149+
150+-- | A data structure that describes the behavior of
151+-- the parseRequestBodyEx function.
152+--
153+-- @since 3.0.16.0
154+data ParseRequestBodyOptions = ParseRequestBodyOptions
155+ { -- | The maximum length of a filename
156+ prboKeyLength :: Maybe Int
157+ , -- | The maximum number of files.
158+ prboMaxNumFiles :: Maybe Int
159+ , -- | The maximum filesize per file.
160+ prboMaxFileSize :: Maybe Int64
161+ , -- | The maximum total filesize.
162+ prboMaxFilesSize :: Maybe Int64
163+ , -- | The maximum size of the sum of all parameters
164+ prboMaxParmsSize :: Maybe Int
165+ , -- | The maximum header lines per mime/multipart entry
166+ prboMaxHeaderLines :: Maybe Int
167+ , -- | The maximum header line length per mime/multipart entry
168+ prboMaxHeaderLineLength :: Maybe Int }
169+
170+-- | Set the maximum length of a filename.
171+--
172+-- @since 3.0.16.0
173+setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
174+setMaxRequestKeyLength l p = p { prboKeyLength=Just l }
175+
176+-- | Do not limit the length of filenames.
177+--
178+-- @since 3.0.16.0
179+clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
180+clearMaxRequestKeyLength p = p { prboKeyLength=Nothing }
181+
182+-- | Set the maximum number of files per request.
183+--
184+-- @since 3.0.16.0
185+setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
186+setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l }
187+
188+-- | Do not limit the maximum number of files per request.
189+--
190+-- @since 3.0.16.0
191+clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
192+clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing }
193+
194+-- | Set the maximum filesize per file (in bytes).
195+--
196+-- @since 3.0.16.0
197+setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
198+setMaxRequestFileSize l p = p { prboMaxFileSize=Just l }
199+
200+-- | Do not limit the maximum filesize per file.
201+--
202+-- @since 3.0.16.0
203+clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
204+clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing }
205+
206+-- | Set the maximum size of all files per request.
207+--
208+-- @since 3.0.16.0
209+setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
210+setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l }
211+
212+-- | Do not limit the maximum size of all files per request.
213+--
214+-- @since 3.0.16.0
215+clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
216+clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing }
217+
218+-- | Set the maximum size of the sum of all parameters.
219+--
220+-- @since 3.0.16.0
221+setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
222+setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l }
223+
224+-- | Do not limit the maximum size of the sum of all parameters.
225+--
226+-- @since 3.0.16.0
227+clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
228+clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing }
229+
230+-- | Set the maximum header lines per mime/multipart entry.
231+--
232+-- @since 3.0.16.0
233+setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
234+setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l }
235+
236+-- | Do not limit the maximum header lines per mime/multipart entry.
237+--
238+-- @since 3.0.16.0
239+clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions
240+clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing }
241+
242+-- | Set the maximum header line length per mime/multipart entry.
243+--
244+-- @since 3.0.16.0
245+setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
246+setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l }
247+
248+-- | Do not limit the maximum header lines per mime/multipart entry.
249+--
250+-- @since 3.0.16.0
251+clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
252+clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }
253+
254+-- | A reasonable default set of parsing options.
255+-- Maximum key/filename length: 32 bytes;
256+-- maximum files: 10; filesize unlimited; maximum
257+-- size for parameters: 64kbytes; maximum number of header
258+-- lines: 32 bytes (applies only to headers of a mime/multipart message);
259+-- maximum header line length: Apache's default for that is 8190 bytes
260+-- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline)
261+-- so we're using that here as well.
262+--
263+-- @since 3.0.16.0
264+defaultParseRequestBodyOptions :: ParseRequestBodyOptions
265+defaultParseRequestBodyOptions = ParseRequestBodyOptions
266+ { prboKeyLength=Just 32
267+ , prboMaxNumFiles=Just 10
268+ , prboMaxFileSize=Nothing
269+ , prboMaxFilesSize=Nothing
270+ , prboMaxParmsSize=Just 65336
271+ , prboMaxHeaderLines=Just 32
272+ , prboMaxHeaderLineLength=Just 8190 }
273+
274+-- | Do not impose any memory limits.
275+--
276+-- @since 3.0.21.0
277+noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
278+noLimitParseRequestBodyOptions = ParseRequestBodyOptions
279+ { prboKeyLength=Nothing
280+ , prboMaxNumFiles=Nothing
281+ , prboMaxFileSize=Nothing
282+ , prboMaxFilesSize=Nothing
283+ , prboMaxParmsSize=Nothing
284+ , prboMaxHeaderLines=Nothing
285+ , prboMaxHeaderLineLength=Nothing }
117286
118287-- | Information on an uploaded file.
119288data FileInfo c = FileInfo
@@ -136,8 +305,16 @@ type BackEnd a = S.ByteString -- ^ parameter name
136305 -> IO S.ByteString
137306 -> IO a
138307
139−data RequestBodyType = UrlEncoded | Multipart S.ByteString
308+-- | The mimetype of the http body.
309+-- Depending on whether just parameters or parameters and files
310+-- are passed, one or the other mimetype should be used.
311+data RequestBodyType
312+ = -- | application/x-www-form-urlencoded (parameters only)
313+ UrlEncoded
314+ | -- | multipart/form-data (parameters and files)
315+ Multipart S.ByteString
140316
317+-- | Get the mimetype of the body of an http request.
141318getRequestBodyType :: Request -> Maybe RequestBodyType
142319getRequestBodyType req = do
143320 ctype' <- lookup hContentType $ requestHeaders req
@@ -150,7 +327,7 @@ getRequestBodyType req = do
150327-- | Parse a content type value, turning a single @ByteString@ into the actual
151328-- content type and a list of pairs of attributes.
152329--
153−-- Since 1.3.2
330+-- @since 1.3.2
154331parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
155332parseContentType a = do
156333 let (ctype, b) = S.break (== semicolon) a
@@ -160,6 +337,9 @@ parseContentType a = do
160337 semicolon = 59
161338 equals = 61
162339 space = 32
340+ dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote
341+ then S.tail $ S.init s
342+ else s
163343 goAttrs front bs
164344 | S.null bs = front []
165345 | otherwise =
@@ -168,79 +348,140 @@ parseContentType a = do
168348 goAttr bs =
169349 let (k, v') = S.break (== equals) bs
170350 v = S.drop 1 v'
171− in (strip k, strip v)
351+ in (strip k, dq $ strip v)
172352 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
173353
354+-- | Parse the body of an HTTP request.
355+-- See parseRequestBodyEx for details.
356+-- Note: This function does not limit the memory it allocates.
357+-- When dealing with untrusted data (as is usually the case when
358+-- receiving input from the internet), it is recommended to
359+-- use the 'parseRequestBodyEx' function instead.
174360parseRequestBody :: BackEnd y
175361 -> Request
176362 -> IO ([Param], [File y])
177−parseRequestBody s r =
363+parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions
364+
365+-- | Parse the body of an HTTP request, limit resource usage.
366+-- The HTTP body can contain both parameters and files.
367+-- This function will return a list of key,value pairs
368+-- for all parameters, and a list of key,a pairs
369+-- for filenames. The a depends on the used backend that
370+-- is responsible for storing the received files.
371+parseRequestBodyEx :: ParseRequestBodyOptions
372+ -> BackEnd y
373+ -> Request
374+ -> IO ([Param], [File y])
375+parseRequestBodyEx o s r =
178376 case getRequestBodyType r of
179377 Nothing -> return ([], [])
180− Just rbt -> sinkRequestBody s rbt (requestBody r)
378+ Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
181379
182380sinkRequestBody :: BackEnd y
183381 -> RequestBodyType
184382 -> IO S.ByteString
185383 -> IO ([Param], [File y])
186−sinkRequestBody s r body = do
187− ref <- newIORef (id, id)
384+sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
385+
386+-- |
387+--
388+-- @since 3.0.16.0
389+sinkRequestBodyEx :: ParseRequestBodyOptions
390+ -> BackEnd y
391+ -> RequestBodyType
392+ -> IO S.ByteString
393+ -> IO ([Param], [File y])
394+sinkRequestBodyEx o s r body = do
395+ ref <- newIORef ([], [])
188396 let add x = atomicModifyIORef ref $ \(y, z) ->
189397 case x of
190− Left y' -> ((y . (y':), z), ())
191− Right z' -> ((y, z . (z':)), ())
192− conduitRequestBody s r body add
193− (x, y) <- readIORef ref
194− return (x [], y [])
195−
196−conduitRequestBody :: BackEnd y
197− -> RequestBodyType
198− -> IO S.ByteString
199− -> (Either Param (File y) -> IO ())
200− -> IO ()
201−conduitRequestBody _ UrlEncoded rbody add = do
398+ Left y' -> ((y':y, z), ())
399+ Right z' -> ((y, z':z), ())
400+ conduitRequestBodyEx o s r body add
401+ (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref
402+
403+conduitRequestBodyEx :: ParseRequestBodyOptions
404+ -> BackEnd y
405+ -> RequestBodyType
406+ -> IO S.ByteString
407+ -> (Either Param (File y) -> IO ())
408+ -> IO ()
409+conduitRequestBodyEx o _ UrlEncoded rbody add = do
202410 -- NOTE: in general, url-encoded data will be in a single chunk.
203411 -- Therefore, I'm optimizing for the usual case by sticking with
204412 -- strict byte strings here.
205− let loop front = do
413+ let loop size front = do
206414 bs <- rbody
207415 if S.null bs
208416 then return $ S.concat $ front []
209− else loop $ front . (bs:)
210− bs <- loop id
417+ else do
418+ let newsize = size + S.length bs
419+ case prboMaxParmsSize o of
420+ Just maxSize -> when (newsize > maxSize) $
421+ error "Maximum size of parameters exceeded"
422+ Nothing -> return ()
423+ loop newsize $ front . (bs:)
424+ bs <- loop 0 id
211425 mapM_ (add . Left) $ H.parseSimpleQuery bs
212−conduitRequestBody backend (Multipart bound) rbody add =
213− parsePieces backend (S8.pack "--" `S.append` bound) rbody add
426+conduitRequestBodyEx o backend (Multipart bound) rbody add =
427+ parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add
428+
214429
215−takeLine :: Source -> IO (Maybe S.ByteString)
216−takeLine src =
217− go id
430+-- | Take one header or subheader line.
431+-- Since: 3.0.26
432+-- Throw 431 if headers too large.
433+takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
434+takeLine maxlen src =
435+ go ""
218436 where
219437 go front = do
220438 bs <- readSource src
439+ case maxlen of
440+ Just maxlen' -> when (S.length front > maxlen') $
441+ E.throwIO $ ConnectionError (UnknownErrorCode 431)
442+ "Request Header Fields Too Large"
443+ Nothing -> return ()
221444 if S.null bs
222445 then close front
223446 else push front bs
224447
225− close front = leftover src (front S.empty) >> return Nothing
448+ close front = leftover src front >> return Nothing
226449 push front bs = do
227− let (x, y) = S.break (== 10) $ front bs -- LF
450+ let (x, y) = S.break (== 10) bs -- LF
228451 in if S.null y
229− then go $ S.append x
452+ then go $ front `S.append` x
230453 else do
231454 when (S.length y > 1) $ leftover src $ S.drop 1 y
232− return $ Just $ killCR x
233−
234−takeLines :: Source -> IO [S.ByteString]
235−takeLines src = do
236− res <- takeLine src
455+ let res = front `S.append` x
456+ case maxlen of
457+ Just maxlen' -> when (S.length res > maxlen') $
458+ E.throwIO $ ConnectionError (UnknownErrorCode 431)
459+ "Request Header Fields Too Large"
460+ Nothing -> return ()
461+ return $ Just $ killCR $ res
462+
463+takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
464+takeLines' lineLength maxLines source =
465+ reverse <$> takeLines'' [] lineLength maxLines source
466+
467+takeLines''
468+ :: [S.ByteString]
469+ -> Maybe Int
470+ -> Maybe Int
471+ -> Source
472+ -> IO [S.ByteString]
473+takeLines'' lines lineLength maxLines src = do
474+ case maxLines of
475+ Just maxLines' ->
476+ when (length lines > maxLines') $
477+ error "Too many lines in mime/multipart header"
478+ Nothing -> return ()
479+ res <- takeLine lineLength src
237480 case res of
238− Nothing -> return []
481+ Nothing -> return lines
239482 Just l
240− | S.null l -> return []
241− | otherwise -> do
242− ls <- takeLines src
243− return $ l : ls
483+ | S.null l -> return lines
484+ | otherwise -> takeLines'' (l:lines) lineLength maxLines src
244485
245486data Source = Source (IO S.ByteString) (IORef S.ByteString)
246487
@@ -259,17 +500,20 @@ readSource (Source f ref) = do
259500leftover :: Source -> S.ByteString -> IO ()
260501leftover (Source _ ref) bs = writeIORef ref bs
261502
262−parsePieces :: BackEnd y
263− -> S.ByteString
264− -> IO S.ByteString
265− -> (Either Param (File y) -> IO ())
266− -> IO ()
267−parsePieces sink bound rbody add =
268− mkSource rbody >>= loop
503+parsePiecesEx :: ParseRequestBodyOptions
504+ -> BackEnd y
505+ -> S.ByteString
506+ -> IO S.ByteString
507+ -> (Either Param (File y) -> IO ())
508+ -> IO ()
509+parsePiecesEx o sink bound rbody add =
510+ mkSource rbody >>= loop 0 0 0 0
269511 where
270− loop src = do
271− _boundLine <- takeLine src
272− res' <- takeLines src
512+ loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
513+ loop numParms numFiles parmSize filesSize src = do
514+ _boundLine <- takeLine (prboMaxHeaderLineLength o) src
515+ res' <- takeLines' (prboMaxHeaderLineLength o)
516+ (prboMaxHeaderLines o) src
273517 unless (null res') $ do
274518 let ls' = map parsePair res'
275519 let x = do
@@ -280,31 +524,57 @@ parsePieces sink bound rbody add =
280524 return (ct, name, lookup "filename" attrs)
281525 case x of
282526 Just (mct, name, Just filename) -> do
527+ case prboKeyLength o of
528+ Just maxKeyLength ->
529+ when (S.length name > maxKeyLength) $
530+ error "Filename is too long"
531+ Nothing -> return ()
532+ case prboMaxNumFiles o of
533+ Just maxFiles -> when (numFiles >= maxFiles) $
534+ error "Maximum number of files exceeded"
535+ Nothing -> return ()
283536 let ct = fromMaybe "application/octet-stream" mct
284537 fi0 = FileInfo filename ct ()
285− (wasFound, y) <- sinkTillBound' bound name fi0 sink src
538+ fs = catMaybes [ prboMaxFileSize o
539+ , subtract filesSize <$> prboMaxFilesSize o ]
540+ mfs = if fs == [] then Nothing else Just $ minimum fs
541+ ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
542+ let newFilesSize = filesSize + fileSize
286543 add $ Right (name, fi0 { fileContent = y })
287− when wasFound (loop src)
544+ when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
288545 Just (_ct, name, Nothing) -> do
546+ case prboKeyLength o of
547+ Just maxKeyLength ->
548+ when (S.length name > maxKeyLength) $
549+ error "Parameter name is too long"
550+ Nothing -> return ()
289551 let seed = id
290552 let iter front bs = return $ front . (:) bs
291− (wasFound, front) <- sinkTillBound bound iter seed src
553+ ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src
554+ (fromIntegral <$> prboMaxParmsSize o)
292555 let bs = S.concat $ front []
293556 let x' = (name, bs)
557+ let newParmSize = parmSize + S.length name + S.length bs
558+ case prboMaxParmsSize o of
559+ Just maxParmSize -> when (newParmSize > maxParmSize) $
560+ error "Maximum size of parameters exceeded"
561+ Nothing -> return ()
294562 add $ Left x'
295− when wasFound (loop src)
563+ when wasFound $ loop (numParms + 1) numFiles
564+ newParmSize filesSize src
296565 _ -> do
297566 -- ignore this part
298567 let seed = ()
299568 iter () _ = return ()
300− (wasFound, ()) <- sinkTillBound bound iter seed src
301− when wasFound (loop src)
569+ ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
570+ when wasFound $ loop numParms numFiles parmSize filesSize src
302571 where
303− contDisp = S8.pack "Content-Disposition"
304− contType = S8.pack "Content-Type"
572+ contDisp = mk $ S8.pack "Content-Disposition"
573+ contType = mk $ S8.pack "Content-Type"
305574 parsePair s =
306575 let (x, y) = breakDiscard 58 s -- colon
307− in (x, S.dropWhile (== 32) y) -- space
576+ in (mk $ x, S.dropWhile (== 32) y) -- space
577+
308578
309579data Bound = FoundBound S.ByteString S.ByteString
310580 | NoBound
@@ -312,7 +582,7 @@ data Bound = FoundBound S.ByteString S.ByteString
312582 deriving (Eq, Show)
313583
314584findBound :: S.ByteString -> S.ByteString -> Bound
315−findBound b bs = handleBreak $ Search.breakOn b bs
585+findBound b bs = handleBreak $ S.breakSubstring b bs
316586 where
317587 handleBreak (h, t)
318588 | S.null t = go [lowBound..S.length bs - 1]
@@ -339,9 +609,10 @@ sinkTillBound' :: S.ByteString
339609 -> FileInfo ()
340610 -> BackEnd y
341611 -> Source
342− -> IO (Bool, y)
343−sinkTillBound' bound name fi sink src = do
344− (next, final) <- wrapTillBound bound src
612+ -> Maybe Int64
613+ -> IO ((Bool, Int64), y)
614+sinkTillBound' bound name fi sink src max' = do
615+ (next, final) <- wrapTillBound bound src max'
345616 y <- sink name fi next
346617 b <- final
347618 return (b, y)
@@ -350,30 +621,40 @@ data WTB = WTBWorking (S.ByteString -> S.ByteString)
350621 | WTBDone Bool
351622wrapTillBound :: S.ByteString -- ^ bound
352623 -> Source
353− -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found
354−wrapTillBound bound src = do
624+ -> Maybe Int64
625+ -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found
626+wrapTillBound bound src max' = do
355627 ref <- newIORef $ WTBWorking id
356− return (go ref, final ref)
628+ sref <- newIORef (0 :: Int64)
629+ return (go ref sref, final ref sref)
357630 where
358− final ref = do
631+ final ref sref = do
359632 x <- readIORef ref
360633 case x of
361634 WTBWorking _ -> error "wrapTillBound did not finish"
362− WTBDone y -> return y
635+ WTBDone y -> do
636+ siz <- readIORef sref
637+ return (y, siz)
363638
364− go ref = do
639+ go ref sref = do
365640 state <- readIORef ref
366641 case state of
367642 WTBDone _ -> return S.empty
368643 WTBWorking front -> do
369644 bs <- readSource src
645+ cur <- atomicModifyIORef' sref $ \ cur ->
646+ let new = cur + fromIntegral (S.length bs) in (new, new)
647+ case max' of
648+ Just max'' | cur > max'' ->
649+ E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"
650+ _ -> return ()
370651 if S.null bs
371652 then do
372653 writeIORef ref $ WTBDone False
373654 return $ front bs
374655 else push $ front bs
375656 where
376− push bs =
657+ push bs = do
377658 case findBound bound bs of
378659 FoundBound before after -> do
379660 let before' = killCRLF before
@@ -389,19 +670,20 @@ wrapTillBound bound src = do
389670 else (bs, id)
390671 writeIORef ref $ WTBWorking front'
391672 if S.null toEmit
392− then go ref
673+ then go ref sref
393674 else return toEmit
394675 PartialBound -> do
395676 writeIORef ref $ WTBWorking $ S.append bs
396− go ref
677+ go ref sref
397678
398679sinkTillBound :: S.ByteString
399680 -> (x -> S.ByteString -> IO x)
400681 -> x
401682 -> Source
402− -> IO (Bool, x)
403−sinkTillBound bound iter seed0 src = do
404− (next, final) <- wrapTillBound bound src
683+ -> Maybe Int64
684+ -> IO ((Bool, Int64), x)
685+sinkTillBound bound iter seed0 src max' = do
686+ (next, final) <- wrapTillBound bound src max'
405687 let loop seed = do
406688 bs <- next
407689 if S.null bs