@@ -11,6 +11,7 @@ module Network.Wai.Parse
11 , RequestBodyType (..)
11 , RequestBodyType (..)
12 , getRequestBodyType
12 , getRequestBodyType
13 , sinkRequestBody
13 , sinkRequestBody
15 , lbsBackEnd
16 , lbsBackEnd
16 , tempFileBackEnd
17 , tempFileBackEnd
@@ -19,6 +20,24 @@ module Network.Wai.Parse
20 , FileInfo (..)
21 , FileInfo (..)
21 , parseContentType
22 , parseContentType
23+ , ParseRequestBodyOptions
24+ , defaultParseRequestBodyOptions
25+ , noLimitParseRequestBodyOptions
27+ , setMaxRequestKeyLength
28+ , clearMaxRequestKeyLength
29+ , setMaxRequestNumFiles
30+ , clearMaxRequestNumFiles
31+ , setMaxRequestFileSize
32+ , clearMaxRequestFileSize
33+ , setMaxRequestFilesSize
34+ , clearMaxRequestFilesSize
35+ , setMaxRequestParmsSize
36+ , clearMaxRequestParmsSize
38+ , clearMaxHeaderLines
39+ , setMaxHeaderLineLength
40+ , clearMaxHeaderLineLength
23 , Bound (..)
42 , Bound (..)
24 , findBound
43 , findBound
@@ -29,24 +48,31 @@ module Network.Wai.Parse
32−import qualified Data.ByteString.Search as Search
51+import qualified Control.Exception as E
33import qualified Data.ByteString as S
52import qualified Data.ByteString as S
34import qualified Data.ByteString.Lazy as L
53import qualified Data.ByteString.Lazy as L
35import qualified Data.ByteString.Char8 as S8
54import qualified Data.ByteString.Char8 as S8
36import Data.Word (Word8)
55import Data.Word (Word8)
56+import Data.Int (Int64)
37−import Data.Maybe (fromMaybe)
57+import Data.Maybe (catMaybes, fromMaybe)
38import Data.List (sortBy)
58import Data.List (sortBy)
39import Data.Function (on, fix)
59import Data.Function (on, fix)
40import System.Directory (removeFile, getTemporaryDirectory)
60import System.Directory (removeFile, getTemporaryDirectory)
41import System.IO (hClose, openBinaryTempFile)
61import System.IO (hClose, openBinaryTempFile)
62+import System.IO.Error (isDoesNotExistError)
42import Network.Wai
63import Network.Wai
43import qualified Network.HTTP.Types as H
64import 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)
45import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
68import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
46import Data.IORef
69import Data.IORef
47import Network.HTTP.Types (hContentType)
70import Network.HTTP.Types (hContentType)
71+import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
48import Data.CaseInsensitive (mk)
72import Data.CaseInsensitive (mk)
74+import Prelude hiding (lines)
50breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
76breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
51breakDiscard w s =
77breakDiscard w s =
52 let (x, y) = S.break (== w) s
78 let (x, y) = S.break (== w) s
@@ -103,11 +129,9 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
103 -> ignored2
129 -> ignored2
104 -> IO S.ByteString
130 -> IO S.ByteString
105 -> IO FilePath
131 -> IO FilePath
106−tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
132+tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
107− (key, (fp, h)) <- flip runInternalState internalState $ allocate (do
133+ (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
108− tempDir <- getTmpDir
109− openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)
110− _ <- runInternalState (register $ removeFile fp) internalState
134+ _ <- runInternalState (register $ removeFileQuiet fp) internalState
111 fix $ \loop -> do
135 fix $ \loop -> do
112 bs <- popper
136 bs <- popper
113 unless (S.null bs) $ do
137 unless (S.null bs) $ do
@@ -115,6 +139,150 @@ tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
116 release key
140 release key
117 return fp
141 return fp
144+ tempDir <- getTmpDir
145+ openBinaryTempFile tempDir pattrn
146+ removeFileQuiet fp = catchJust (guard . isDoesNotExistError)
150+-- | A data structure that describes the behavior of
151+-- the parseRequestBodyEx function.
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 }
170+-- | Set the maximum length of a filename.
173+setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
174+setMaxRequestKeyLength l p = p { prboKeyLength=Just l }
176+-- | Do not limit the length of filenames.
179+clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
180+clearMaxRequestKeyLength p = p { prboKeyLength=Nothing }
182+-- | Set the maximum number of files per request.
185+setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
186+setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l }
188+-- | Do not limit the maximum number of files per request.
191+clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
192+clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing }
194+-- | Set the maximum filesize per file (in bytes).
197+setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
198+setMaxRequestFileSize l p = p { prboMaxFileSize=Just l }
200+-- | Do not limit the maximum filesize per file.
203+clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
204+clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing }
206+-- | Set the maximum size of all files per request.
209+setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
210+setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l }
212+-- | Do not limit the maximum size of all files per request.
215+clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
216+clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing }
218+-- | Set the maximum size of the sum of all parameters.
221+setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
222+setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l }
224+-- | Do not limit the maximum size of the sum of all parameters.
227+clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
228+clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing }
230+-- | Set the maximum header lines per mime/multipart entry.
233+setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
234+setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l }
236+-- | Do not limit the maximum header lines per mime/multipart entry.
239+clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions
240+clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing }
242+-- | Set the maximum header line length per mime/multipart entry.
245+setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
246+setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l }
248+-- | Do not limit the maximum header lines per mime/multipart entry.
251+clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
252+clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }
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.
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 }
274+-- | Do not impose any memory limits.
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 }
119-- | Information on an uploaded file.
287-- | Information on an uploaded file.
120data FileInfo c = FileInfo
288data FileInfo c = FileInfo
@@ -137,8 +305,16 @@ type BackEnd a = S.ByteString -- ^ parameter name
137 -> IO S.ByteString
305 -> IO 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.
312+ = -- | application/x-www-form-urlencoded (parameters only)
314+ | -- | multipart/form-data (parameters and files)
140−data RequestBodyType = UrlEncoded | Multipart S.ByteString
315+ Multipart S.ByteString
317+-- | Get the mimetype of the body of an http request.
142getRequestBodyType :: Request -> Maybe RequestBodyType
318getRequestBodyType :: Request -> Maybe RequestBodyType
143getRequestBodyType req = do
319getRequestBodyType req = do
144 ctype' <- lookup hContentType $ requestHeaders req
320 ctype' <- lookup hContentType $ requestHeaders req
@@ -151,7 +327,7 @@ getRequestBodyType req = do
151-- | Parse a content type value, turning a single @ByteString@ into the actual
327-- | Parse a content type value, turning a single @ByteString@ into the actual
152-- content type and a list of pairs of attributes.
328-- content type and a list of pairs of attributes.
154−-- Since 1.3.2
330+-- @since 1.3.2
155parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
331parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
156parseContentType a = do
332parseContentType a = do
157 let (ctype, b) = S.break (== semicolon) a
333 let (ctype, b) = S.break (== semicolon) a
@@ -161,6 +337,9 @@ parseContentType a = do
161 semicolon = 59
337 semicolon = 59
162 equals = 61
338 equals = 61
163 space = 32
339 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
164 goAttrs front bs
343 goAttrs front bs
165 | S.null bs = front []
344 | S.null bs = front []
166 | otherwise =
345 | otherwise =
@@ -169,79 +348,140 @@ parseContentType a = do
169 goAttr bs =
348 goAttr bs =
170 let (k, v') = S.break (== equals) bs
349 let (k, v') = S.break (== equals) bs
171 v = S.drop 1 v'
350 v = S.drop 1 v'
172− in (strip k, strip v)
351+ in (strip k, dq $ strip v)
173 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
352 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
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.
175parseRequestBody :: BackEnd y
360parseRequestBody :: BackEnd y
176 -> Request
361 -> Request
177 -> IO ([Param], [File y])
362 -> IO ([Param], [File y])
178−parseRequestBody s r =
363+parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions
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
374+ -> IO ([Param], [File y])
375+parseRequestBodyEx o s r =
179 case getRequestBodyType r of
376 case getRequestBodyType r of
180 Nothing -> return ([], [])
377 Nothing -> return ([], [])
181− Just rbt -> sinkRequestBody s rbt (requestBody r)
378+ Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
183sinkRequestBody :: BackEnd y
380sinkRequestBody :: BackEnd y
184 -> RequestBodyType
381 -> RequestBodyType
185 -> IO S.ByteString
382 -> IO S.ByteString
186 -> IO ([Param], [File y])
383 -> IO ([Param], [File y])
187−sinkRequestBody s r body = do
384+sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
389+sinkRequestBodyEx :: ParseRequestBodyOptions
393+ -> IO ([Param], [File y])
394+sinkRequestBodyEx o s r body = do
188− ref <- newIORef (id, id)
395+ ref <- newIORef ([], [])
189 let add x = atomicModifyIORef ref $ \(y, z) ->
396 let add x = atomicModifyIORef ref $ \(y, z) ->
190 case x of
397 case x of
191− Left y' -> ((y . (y':), z), ())
398+ Left y' -> ((y':y, z), ())
192− Right z' -> ((y, z . (z':)), ())
399+ Right z' -> ((y, z':z), ())
193− conduitRequestBody s r body add
400+ conduitRequestBodyEx o s r body add
194− (x, y) <- readIORef ref
401+ (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref
195− return (x [], y [])
402+
196−
403+conduitRequestBodyEx :: ParseRequestBodyOptions
197−conduitRequestBody :: BackEnd y
404+ -> BackEnd y
198− -> RequestBodyType
405+ -> RequestBodyType
199− -> IO S.ByteString
406+ -> IO S.ByteString
200− -> (Either Param (File y) -> IO ())
407+ -> (Either Param (File y) -> IO ())
201− -> IO ()
408+ -> IO ()
202−conduitRequestBody _ UrlEncoded rbody add = do
409+conduitRequestBodyEx o _ UrlEncoded rbody add = do
203 -- NOTE: in general, url-encoded data will be in a single chunk.
410 -- NOTE: in general, url-encoded data will be in a single chunk.
204 -- Therefore, I'm optimizing for the usual case by sticking with
411 -- Therefore, I'm optimizing for the usual case by sticking with
205 -- strict byte strings here.
412 -- strict byte strings here.
206− let loop front = do
413+ let loop size front = do
207 bs <- rbody
414 bs <- rbody
208 if S.null bs
415 if S.null bs
209 then return $ S.concat $ front []
416 then return $ S.concat $ front []
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 ()
210− else loop $ front . (bs:)
423+ loop newsize $ front . (bs:)
211− bs <- loop id
424+ bs <- loop 0 id
212 mapM_ (add . Left) $ H.parseSimpleQuery bs
425 mapM_ (add . Left) $ H.parseSimpleQuery bs
213−conduitRequestBody backend (Multipart bound) rbody add =
426+conduitRequestBodyEx o backend (Multipart bound) rbody add =
214− parsePieces backend (S8.pack "--" `S.append` bound) rbody add
427+ parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add
430+-- | Take one header or subheader line.
432+-- Throw 431 if headers too large.
216−takeLine :: Source -> IO (Maybe S.ByteString)
433+takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
217−takeLine src =
434+takeLine maxlen src =
220 go front = do
437 go front = do
221 bs <- readSource src
438 bs <- readSource src
440+ Just maxlen' -> when (S.length front > maxlen') $
441+ E.throwIO $ ConnectionError (UnknownErrorCode 431)
442+ "Request Header Fields Too Large"
443+ Nothing -> return ()
222 if S.null bs
444 if S.null bs
223 then close front
445 then close front
224 else push front bs
446 else push front bs
226− close front = leftover src (front S.empty) >> return Nothing
448+ close front = leftover src front >> return Nothing
227 push front bs = do
449 push front bs = do
228− let (x, y) = S.break (== 10) $ front bs -- LF
450+ let (x, y) = S.break (== 10) bs -- LF
229 in if S.null y
451 in if S.null y
230− then go $ S.append x
452+ then go $ front `S.append` x
232 when (S.length y > 1) $ leftover src $ S.drop 1 y
454 when (S.length y > 1) $ leftover src $ S.drop 1 y
233− return $ Just $ killCR x
455+ let res = front `S.append` x
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
235−takeLines :: Source -> IO [S.ByteString]
463+takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
236−takeLines src = do
464+takeLines' lineLength maxLines source =
465+ reverse <$> takeLines'' [] lineLength maxLines source
472+ -> IO [S.ByteString]
473+takeLines'' lines lineLength maxLines src = do
476+ when (length lines > maxLines') $
477+ error "Too many lines in mime/multipart header"
478+ Nothing -> return ()
237− res <- takeLine src
479+ res <- takeLine lineLength src
238 case res of
480 case res of
239− Nothing -> return []
481+ Nothing -> return lines
241− | S.null l -> return []
483+ | S.null l -> return lines
242− | otherwise -> do
484+ | otherwise -> takeLines'' (l:lines) lineLength maxLines src
246data Source = Source (IO S.ByteString) (IORef S.ByteString)
486data Source = Source (IO S.ByteString) (IORef S.ByteString)
@@ -260,17 +500,20 @@ readSource (Source f ref) = do
260leftover :: Source -> S.ByteString -> IO ()
500leftover :: Source -> S.ByteString -> IO ()
261leftover (Source _ ref) bs = writeIORef ref bs
501leftover (Source _ ref) bs = writeIORef ref bs
503+parsePiecesEx :: ParseRequestBodyOptions
263−parsePieces :: BackEnd y
504+ -> BackEnd y
264− -> S.ByteString
505+ -> S.ByteString
265− -> IO S.ByteString
506+ -> IO S.ByteString
266− -> (Either Param (File y) -> IO ())
507+ -> (Either Param (File y) -> IO ())
267− -> IO ()
508+ -> IO ()
268−parsePieces sink bound rbody add =
509+parsePiecesEx o sink bound rbody add =
269− mkSource rbody >>= loop
510+ mkSource rbody >>= loop 0 0 0 0
271− loop src = do
512+ loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
513+ loop numParms numFiles parmSize filesSize src = do
272− _boundLine <- takeLine src
514+ _boundLine <- takeLine (prboMaxHeaderLineLength o) src
273− res' <- takeLines src
515+ res' <- takeLines' (prboMaxHeaderLineLength o)
516+ (prboMaxHeaderLines o) src
274 unless (null res') $ do
517 unless (null res') $ do
275 let ls' = map parsePair res'
518 let ls' = map parsePair res'
276 let x = do
519 let x = do
@@ -281,25 +524,50 @@ parsePieces sink bound rbody add =
281 return (ct, name, lookup "filename" attrs)
524 return (ct, name, lookup "filename" attrs)
282 case x of
525 case x of
283 Just (mct, name, Just filename) -> do
526 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 ()
284 let ct = fromMaybe "application/octet-stream" mct
536 let ct = fromMaybe "application/octet-stream" mct
285 fi0 = FileInfo filename ct ()
537 fi0 = FileInfo filename ct ()
538+ fs = catMaybes [ prboMaxFileSize o
539+ , subtract filesSize <$> prboMaxFilesSize o ]
540+ mfs = if fs == [] then Nothing else Just $ minimum fs
286− (wasFound, y) <- sinkTillBound' bound name fi0 sink src
541+ ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
542+ let newFilesSize = filesSize + fileSize
287 add $ Right (name, fi0 { fileContent = y })
543 add $ Right (name, fi0 { fileContent = y })
288− when wasFound (loop src)
544+ when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
289 Just (_ct, name, Nothing) -> do
545 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 ()
290 let seed = id
551 let seed = id
291 let iter front bs = return $ front . (:) bs
552 let iter front bs = return $ front . (:) bs
292− (wasFound, front) <- sinkTillBound bound iter seed src
553+ ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src
554+ (fromIntegral <$> prboMaxParmsSize o)
293 let bs = S.concat $ front []
555 let bs = S.concat $ front []
294 let x' = (name, bs)
556 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 ()
295 add $ Left x'
562 add $ Left x'
296− when wasFound (loop src)
563+ when wasFound $ loop (numParms + 1) numFiles
564+ newParmSize filesSize src
298 -- ignore this part
566 -- ignore this part
299 let seed = ()
567 let seed = ()
300 iter () _ = return ()
568 iter () _ = return ()
301− (wasFound, ()) <- sinkTillBound bound iter seed src
569+ ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
302− when wasFound (loop src)
570+ when wasFound $ loop numParms numFiles parmSize filesSize src
304 contDisp = mk $ S8.pack "Content-Disposition"
572 contDisp = mk $ S8.pack "Content-Disposition"
305 contType = mk $ S8.pack "Content-Type"
573 contType = mk $ S8.pack "Content-Type"
@@ -307,13 +575,14 @@ parsePieces sink bound rbody add =
307 let (x, y) = breakDiscard 58 s -- colon
575 let (x, y) = breakDiscard 58 s -- colon
308 in (mk $ x, S.dropWhile (== 32) y) -- space
576 in (mk $ x, S.dropWhile (== 32) y) -- space
310data Bound = FoundBound S.ByteString S.ByteString
579data Bound = FoundBound S.ByteString S.ByteString
311 | NoBound
580 | NoBound
312 | PartialBound
581 | PartialBound
313 deriving (Eq, Show)
582 deriving (Eq, Show)
315findBound :: S.ByteString -> S.ByteString -> Bound
584findBound :: S.ByteString -> S.ByteString -> Bound
316−findBound b bs = handleBreak $ Search.breakOn b bs
585+findBound b bs = handleBreak $ S.breakSubstring b bs
318 handleBreak (h, t)
587 handleBreak (h, t)
319 | S.null t = go [lowBound..S.length bs - 1]
588 | S.null t = go [lowBound..S.length bs - 1]
@@ -340,9 +609,10 @@ sinkTillBound' :: S.ByteString
340 -> FileInfo ()
609 -> FileInfo ()
341 -> BackEnd y
610 -> BackEnd y
342 -> Source
611 -> Source
343− -> IO (Bool, y)
613+ -> IO ((Bool, Int64), y)
344−sinkTillBound' bound name fi sink src = do
614+sinkTillBound' bound name fi sink src max' = do
345− (next, final) <- wrapTillBound bound src
615+ (next, final) <- wrapTillBound bound src max'
346 y <- sink name fi next
616 y <- sink name fi next
347 b <- final
617 b <- final
348 return (b, y)
618 return (b, y)
@@ -351,30 +621,40 @@ data WTB = WTBWorking (S.ByteString -> S.ByteString)
351 | WTBDone Bool
621 | WTBDone Bool
352wrapTillBound :: S.ByteString -- ^ bound
622wrapTillBound :: S.ByteString -- ^ bound
353 -> Source
623 -> Source
354− -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found
625+ -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found
355−wrapTillBound bound src = do
626+wrapTillBound bound src max' = do
356 ref <- newIORef $ WTBWorking id
627 ref <- newIORef $ WTBWorking id
628+ sref <- newIORef (0 :: Int64)
357− return (go ref, final ref)
629+ return (go ref sref, final ref sref)
359− final ref = do
631+ final ref sref = do
360 x <- readIORef ref
632 x <- readIORef ref
361 case x of
633 case x of
362 WTBWorking _ -> error "wrapTillBound did not finish"
634 WTBWorking _ -> error "wrapTillBound did not finish"
363− WTBDone y -> return y
635+ WTBDone y -> do
636+ siz <- readIORef sref
365− go ref = do
639+ go ref sref = do
366 state <- readIORef ref
640 state <- readIORef ref
367 case state of
641 case state of
368 WTBDone _ -> return S.empty
642 WTBDone _ -> return S.empty
369 WTBWorking front -> do
643 WTBWorking front -> do
370 bs <- readSource src
644 bs <- readSource src
645+ cur <- atomicModifyIORef' sref $ \ cur ->
646+ let new = cur + fromIntegral (S.length bs) in (new, new)
648+ Just max'' | cur > max'' ->
649+ E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"
371 if S.null bs
651 if S.null bs
373 writeIORef ref $ WTBDone False
653 writeIORef ref $ WTBDone False
374 return $ front bs
654 return $ front bs
375 else push $ front bs
655 else push $ front bs
377− push bs =
657+ push bs = do
378 case findBound bound bs of
658 case findBound bound bs of
379 FoundBound before after -> do
659 FoundBound before after -> do
380 let before' = killCRLF before
660 let before' = killCRLF before
@@ -390,19 +670,20 @@ wrapTillBound bound src = do
390 else (bs, id)
670 else (bs, id)
391 writeIORef ref $ WTBWorking front'
671 writeIORef ref $ WTBWorking front'
392 if S.null toEmit
672 if S.null toEmit
393− then go ref
673+ then go ref sref
394 else return toEmit
674 else return toEmit
395 PartialBound -> do
675 PartialBound -> do
396 writeIORef ref $ WTBWorking $ S.append bs
676 writeIORef ref $ WTBWorking $ S.append bs
397− go ref
677+ go ref sref
399sinkTillBound :: S.ByteString
679sinkTillBound :: S.ByteString
400 -> (x -> S.ByteString -> IO x)
680 -> (x -> S.ByteString -> IO x)
402 -> Source
682 -> Source
403− -> IO (Bool, x)
684+ -> IO ((Bool, Int64), x)
404−sinkTillBound bound iter seed0 src = do
685+sinkTillBound bound iter seed0 src max' = do
405− (next, final) <- wrapTillBound bound src
686+ (next, final) <- wrapTillBound bound src max'
406 let loop seed = do
687 let loop seed = do
407 bs <- next
688 bs <- next
408 if S.null bs
689 if S.null bs