@@ -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,22 +48,30 @@ 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 (..) )
72+import Data.CaseInsensitive (mk)
74+import Prelude hiding (lines)
49breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
76breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
50breakDiscard w s =
77breakDiscard w s =
@@ -94,7 +121,7 @@ lbsBackEnd _ _ popper =
94tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
121tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
95tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"
122tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"
97−-- | Same as 'tempFileSink', but use configurable temp folders and patterns.
124+-- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.
98tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
125tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
99 -> String -- ^ filename pattern
126 -> String -- ^ filename pattern
100 -> InternalState
127 -> InternalState
@@ -102,11 +129,9 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
102 -> ignored2
129 -> ignored2
103 -> IO S.ByteString
130 -> IO S.ByteString
104 -> IO FilePath
131 -> IO FilePath
105−tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
132+tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
106− (key, (fp, h)) <- flip runInternalState internalState $ allocate (do
133+ (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
107− tempDir <- getTmpDir
108− openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)
109− _ <- runInternalState (register $ removeFile fp) internalState
134+ _ <- runInternalState (register $ removeFileQuiet fp) internalState
110 fix $ \loop -> do
135 fix $ \loop -> do
111 bs <- popper
136 bs <- popper
112 unless (S.null bs) $ do
137 unless (S.null bs) $ do
@@ -114,6 +139,150 @@ tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
115 release key
140 release key
116 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 }
118-- | Information on an uploaded file.
287-- | Information on an uploaded file.
119data FileInfo c = FileInfo
288data FileInfo c = FileInfo
@@ -136,8 +305,16 @@ type BackEnd a = S.ByteString -- ^ parameter name
136 -> 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)
139−data RequestBodyType = UrlEncoded | Multipart S.ByteString
315+ Multipart S.ByteString
317+-- | Get the mimetype of the body of an http request.
141getRequestBodyType :: Request -> Maybe RequestBodyType
318getRequestBodyType :: Request -> Maybe RequestBodyType
142getRequestBodyType req = do
319getRequestBodyType req = do
143 ctype' <- lookup hContentType $ requestHeaders req
320 ctype' <- lookup hContentType $ requestHeaders req
@@ -150,7 +327,7 @@ getRequestBodyType req = do
150-- | 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
151-- content type and a list of pairs of attributes.
328-- content type and a list of pairs of attributes.
153−-- Since 1.3.2
330+-- @since 1.3.2
154parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
331parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
155parseContentType a = do
332parseContentType a = do
156 let (ctype, b) = S.break (== semicolon) a
333 let (ctype, b) = S.break (== semicolon) a
@@ -160,6 +337,9 @@ parseContentType a = do
160 semicolon = 59
337 semicolon = 59
161 equals = 61
338 equals = 61
162 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
163 goAttrs front bs
343 goAttrs front bs
164 | S.null bs = front []
344 | S.null bs = front []
165 | otherwise =
345 | otherwise =
@@ -168,79 +348,140 @@ parseContentType a = do
168 goAttr bs =
348 goAttr bs =
169 let (k, v') = S.break (== equals) bs
349 let (k, v') = S.break (== equals) bs
170 v = S.drop 1 v'
350 v = S.drop 1 v'
171− in (strip k, strip v)
351+ in (strip k, dq $ strip v)
172 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.
174parseRequestBody :: BackEnd y
360parseRequestBody :: BackEnd y
175 -> Request
361 -> Request
176 -> IO ([Param], [File y])
362 -> IO ([Param], [File y])
177−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 =
178 case getRequestBodyType r of
376 case getRequestBodyType r of
179 Nothing -> return ([], [])
377 Nothing -> return ([], [])
180− Just rbt -> sinkRequestBody s rbt (requestBody r)
378+ Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
182sinkRequestBody :: BackEnd y
380sinkRequestBody :: BackEnd y
183 -> RequestBodyType
381 -> RequestBodyType
184 -> IO S.ByteString
382 -> IO S.ByteString
185 -> IO ([Param], [File y])
383 -> IO ([Param], [File y])
186−sinkRequestBody s r body = do
384+sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
389+sinkRequestBodyEx :: ParseRequestBodyOptions
393+ -> IO ([Param], [File y])
394+sinkRequestBodyEx o s r body = do
187− ref <- newIORef (id, id)
395+ ref <- newIORef ([], [])
188 let add x = atomicModifyIORef ref $ \(y, z) ->
396 let add x = atomicModifyIORef ref $ \(y, z) ->
189 case x of
397 case x of
190− Left y' -> ((y . (y':), z), ())
398+ Left y' -> ((y':y, z), ())
191− Right z' -> ((y, z . (z':)), ())
399+ Right z' -> ((y, z':z), ())
192− conduitRequestBody s r body add
400+ conduitRequestBodyEx o s r body add
193− (x, y) <- readIORef ref
401+ (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref
194− return (x [], y [])
402+
195−
403+conduitRequestBodyEx :: ParseRequestBodyOptions
196−conduitRequestBody :: BackEnd y
404+ -> BackEnd y
197− -> RequestBodyType
405+ -> RequestBodyType
198− -> IO S.ByteString
406+ -> IO S.ByteString
199− -> (Either Param (File y) -> IO ())
407+ -> (Either Param (File y) -> IO ())
200− -> IO ()
408+ -> IO ()
201−conduitRequestBody _ UrlEncoded rbody add = do
409+conduitRequestBodyEx o _ UrlEncoded rbody add = do
202 -- 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.
203 -- Therefore, I'm optimizing for the usual case by sticking with
411 -- Therefore, I'm optimizing for the usual case by sticking with
204 -- strict byte strings here.
412 -- strict byte strings here.
205− let loop front = do
413+ let loop size front = do
206 bs <- rbody
414 bs <- rbody
207 if S.null bs
415 if S.null bs
208 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 ()
209− else loop $ front . (bs:)
423+ loop newsize $ front . (bs:)
210− bs <- loop id
424+ bs <- loop 0 id
211 mapM_ (add . Left) $ H.parseSimpleQuery bs
425 mapM_ (add . Left) $ H.parseSimpleQuery bs
212−conduitRequestBody backend (Multipart bound) rbody add =
426+conduitRequestBodyEx o backend (Multipart bound) rbody add =
213− 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.
215−takeLine :: Source -> IO (Maybe S.ByteString)
433+takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
216−takeLine src =
434+takeLine maxlen src =
219 go front = do
437 go front = do
220 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 ()
221 if S.null bs
444 if S.null bs
222 then close front
445 then close front
223 else push front bs
446 else push front bs
225− close front = leftover src (front S.empty) >> return Nothing
448+ close front = leftover src front >> return Nothing
226 push front bs = do
449 push front bs = do
227− let (x, y) = S.break (== 10) $ front bs -- LF
450+ let (x, y) = S.break (== 10) bs -- LF
228 in if S.null y
451 in if S.null y
229− then go $ S.append x
452+ then go $ front `S.append` x
231 when (S.length y > 1) $ leftover src $ S.drop 1 y
454 when (S.length y > 1) $ leftover src $ S.drop 1 y
232− 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
234−takeLines :: Source -> IO [S.ByteString]
463+takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
235−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 ()
236− res <- takeLine src
479+ res <- takeLine lineLength src
237 case res of
480 case res of
238− Nothing -> return []
481+ Nothing -> return lines
240− | S.null l -> return []
483+ | S.null l -> return lines
241− | otherwise -> do
484+ | otherwise -> takeLines'' (l:lines) lineLength maxLines src
245data Source = Source (IO S.ByteString) (IORef S.ByteString)
486data Source = Source (IO S.ByteString) (IORef S.ByteString)
@@ -259,17 +500,20 @@ readSource (Source f ref) = do
259leftover :: Source -> S.ByteString -> IO ()
500leftover :: Source -> S.ByteString -> IO ()
260leftover (Source _ ref) bs = writeIORef ref bs
501leftover (Source _ ref) bs = writeIORef ref bs
503+parsePiecesEx :: ParseRequestBodyOptions
262−parsePieces :: BackEnd y
504+ -> BackEnd y
263− -> S.ByteString
505+ -> S.ByteString
264− -> IO S.ByteString
506+ -> IO S.ByteString
265− -> (Either Param (File y) -> IO ())
507+ -> (Either Param (File y) -> IO ())
266− -> IO ()
508+ -> IO ()
267−parsePieces sink bound rbody add =
509+parsePiecesEx o sink bound rbody add =
268− mkSource rbody >>= loop
510+ mkSource rbody >>= loop 0 0 0 0
270− loop src = do
512+ loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
513+ loop numParms numFiles parmSize filesSize src = do
271− _boundLine <- takeLine src
514+ _boundLine <- takeLine (prboMaxHeaderLineLength o) src
272− res' <- takeLines src
515+ res' <- takeLines' (prboMaxHeaderLineLength o)
516+ (prboMaxHeaderLines o) src
273 unless (null res') $ do
517 unless (null res') $ do
274 let ls' = map parsePair res'
518 let ls' = map parsePair res'
275 let x = do
519 let x = do
@@ -280,31 +524,57 @@ parsePieces sink bound rbody add =
280 return (ct, name, lookup "filename" attrs)
524 return (ct, name, lookup "filename" attrs)
281 case x of
525 case x of
282 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 ()
283 let ct = fromMaybe "application/octet-stream" mct
536 let ct = fromMaybe "application/octet-stream" mct
284 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
285− (wasFound, y) <- sinkTillBound' bound name fi0 sink src
541+ ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
542+ let newFilesSize = filesSize + fileSize
286 add $ Right (name, fi0 { fileContent = y })
543 add $ Right (name, fi0 { fileContent = y })
287− when wasFound (loop src)
544+ when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
288 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 ()
289 let seed = id
551 let seed = id
290 let iter front bs = return $ front . (:) bs
552 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)
292 let bs = S.concat $ front []
555 let bs = S.concat $ front []
293 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 ()
294 add $ Left x'
562 add $ Left x'
295− when wasFound (loop src)
563+ when wasFound $ loop (numParms + 1) numFiles
564+ newParmSize filesSize src
297 -- ignore this part
566 -- ignore this part
298 let seed = ()
567 let seed = ()
299 iter () _ = return ()
568 iter () _ = return ()
300− (wasFound, ()) <- sinkTillBound bound iter seed src
569+ ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
301− when wasFound (loop src)
570+ when wasFound $ loop numParms numFiles parmSize filesSize src
303− contDisp = S8.pack "Content-Disposition"
572+ contDisp = mk $ S8.pack "Content-Disposition"
304− contType = S8.pack "Content-Type"
573+ contType = mk $ S8.pack "Content-Type"
305 parsePair s =
574 parsePair s =
306 let (x, y) = breakDiscard 58 s -- colon
575 let (x, y) = breakDiscard 58 s -- colon
307− in (x, S.dropWhile (== 32) y) -- space
576+ in (mk $ x, S.dropWhile (== 32) y) -- space
309data Bound = FoundBound S.ByteString S.ByteString
579data Bound = FoundBound S.ByteString S.ByteString
310 | NoBound
580 | NoBound
@@ -312,7 +582,7 @@ data Bound = FoundBound S.ByteString S.ByteString
312 deriving (Eq, Show)
582 deriving (Eq, Show)
314findBound :: S.ByteString -> S.ByteString -> Bound
584findBound :: S.ByteString -> S.ByteString -> Bound
315−findBound b bs = handleBreak $ Search.breakOn b bs
585+findBound b bs = handleBreak $ S.breakSubstring b bs
317 handleBreak (h, t)
587 handleBreak (h, t)
318 | S.null t = go [lowBound..S.length bs - 1]
588 | S.null t = go [lowBound..S.length bs - 1]
@@ -339,9 +609,10 @@ sinkTillBound' :: S.ByteString
339 -> FileInfo ()
609 -> FileInfo ()
340 -> BackEnd y
610 -> BackEnd y
341 -> Source
611 -> Source
342− -> IO (Bool, y)
613+ -> IO ((Bool, Int64), y)
343−sinkTillBound' bound name fi sink src = do
614+sinkTillBound' bound name fi sink src max' = do
344− (next, final) <- wrapTillBound bound src
615+ (next, final) <- wrapTillBound bound src max'
345 y <- sink name fi next
616 y <- sink name fi next
346 b <- final
617 b <- final
347 return (b, y)
618 return (b, y)
@@ -350,30 +621,40 @@ data WTB = WTBWorking (S.ByteString -> S.ByteString)
350 | WTBDone Bool
621 | WTBDone Bool
351wrapTillBound :: S.ByteString -- ^ bound
622wrapTillBound :: S.ByteString -- ^ bound
352 -> Source
623 -> Source
353− -> 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
354−wrapTillBound bound src = do
626+wrapTillBound bound src max' = do
355 ref <- newIORef $ WTBWorking id
627 ref <- newIORef $ WTBWorking id
628+ sref <- newIORef (0 :: Int64)
356− return (go ref, final ref)
629+ return (go ref sref, final ref sref)
358− final ref = do
631+ final ref sref = do
359 x <- readIORef ref
632 x <- readIORef ref
360 case x of
633 case x of
361 WTBWorking _ -> error "wrapTillBound did not finish"
634 WTBWorking _ -> error "wrapTillBound did not finish"
362− WTBDone y -> return y
635+ WTBDone y -> do
636+ siz <- readIORef sref
364− go ref = do
639+ go ref sref = do
365 state <- readIORef ref
640 state <- readIORef ref
366 case state of
641 case state of
367 WTBDone _ -> return S.empty
642 WTBDone _ -> return S.empty
368 WTBWorking front -> do
643 WTBWorking front -> do
369 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"
370 if S.null bs
651 if S.null bs
372 writeIORef ref $ WTBDone False
653 writeIORef ref $ WTBDone False
373 return $ front bs
654 return $ front bs
374 else push $ front bs
655 else push $ front bs
376− push bs =
657+ push bs = do
377 case findBound bound bs of
658 case findBound bound bs of
378 FoundBound before after -> do
659 FoundBound before after -> do
379 let before' = killCRLF before
660 let before' = killCRLF before
@@ -389,19 +670,20 @@ wrapTillBound bound src = do
389 else (bs, id)
670 else (bs, id)
390 writeIORef ref $ WTBWorking front'
671 writeIORef ref $ WTBWorking front'
391 if S.null toEmit
672 if S.null toEmit
392− then go ref
673+ then go ref sref
393 else return toEmit
674 else return toEmit
394 PartialBound -> do
675 PartialBound -> do
395 writeIORef ref $ WTBWorking $ S.append bs
676 writeIORef ref $ WTBWorking $ S.append bs
396− go ref
677+ go ref sref
398sinkTillBound :: S.ByteString
679sinkTillBound :: S.ByteString
399 -> (x -> S.ByteString -> IO x)
680 -> (x -> S.ByteString -> IO x)
401 -> Source
682 -> Source
402− -> IO (Bool, x)
684+ -> IO ((Bool, Int64), x)
403−sinkTillBound bound iter seed0 src = do
685+sinkTillBound bound iter seed0 src max' = do
404− (next, final) <- wrapTillBound bound src
686+ (next, final) <- wrapTillBound bound src max'
405 let loop seed = do
687 let loop seed = do
406 bs <- next
688 bs <- next
407 if S.null bs
689 if S.null bs