@@ -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,23 @@ module Network.Wai.Parse
1920 , File
2021 , FileInfo (..)
2122 , parseContentType
23+ , ParseRequestBodyOptions
24+ , defaultParseRequestBodyOptions
25+ , parseRequestBodyEx
26+ , setMaxRequestKeyLength
27+ , clearMaxRequestKeyLength
28+ , setMaxRequestNumFiles
29+ , clearMaxRequestNumFiles
30+ , setMaxRequestFileSize
31+ , clearMaxRequestFileSize
32+ , setMaxRequestFilesSize
33+ , clearMaxRequestFilesSize
34+ , setMaxRequestParmsSize
35+ , clearMaxRequestParmsSize
36+ , setMaxHeaderLines
37+ , clearMaxHeaderLines
38+ , setMaxHeaderLineLength
39+ , clearMaxHeaderLineLength
2240#if TEST
2341 , Bound (..)
2442 , findBound
@@ -34,19 +52,23 @@ import qualified Data.ByteString as S
3452import qualified Data.ByteString.Lazy as L
3553import qualified Data.ByteString.Char8 as S8
3654import Data.Word (Word8)
37−import Data.Maybe (fromMaybe)
55+import Data.Int (Int64)
56+import Data.Maybe (catMaybes, fromMaybe)
3857import Data.List (sortBy)
3958import Data.Function (on, fix)
4059import System.Directory (removeFile, getTemporaryDirectory)
4160import System.IO (hClose, openBinaryTempFile)
4261import Network.Wai
4362import qualified Network.HTTP.Types as H
63+import Control.Applicative ((<$>))
4464import Control.Monad (when, unless)
4565import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
4666import Data.IORef
4767import Network.HTTP.Types (hContentType)
4868import Data.CaseInsensitive (mk)
4969
70+import Prelude hiding (lines)
71+
5072breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
5173breakDiscard w s =
5274 let (x, y) = S.break (== w) s
@@ -103,10 +125,8 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
103125 -> ignored2
104126 -> IO S.ByteString
105127 -> IO FilePath
106−tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
107− (key, (fp, h)) <- flip runInternalState internalState $ allocate (do
108− tempDir <- getTmpDir
109− openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)
128+tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
129+ (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
110130 _ <- runInternalState (register $ removeFile fp) internalState
111131 fix $ \loop -> do
112132 bs <- popper
@@ -115,6 +135,113 @@ tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
115135 loop
116136 release key
117137 return fp
138+ where
139+ it = do
140+ tempDir <- getTmpDir
141+ openBinaryTempFile tempDir pattrn
142+
143+-- | A data structure that describes the behavior of
144+-- the parseRequestBodyEx function.
145+data ParseRequestBodyOptions = ParseRequestBodyOptions
146+ { -- | The maximum length of a filename
147+ prboKeyLength :: Maybe Int
148+ , -- | The maximum number of files.
149+ prboMaxNumFiles :: Maybe Int
150+ , -- | The maximum filesize per file.
151+ prboMaxFileSize :: Maybe Int64
152+ , -- | The maximum total filesize.
153+ prboMaxFilesSize :: Maybe Int64
154+ , -- | The maximum size of the sum of all parameters
155+ prboMaxParmsSize :: Maybe Int
156+ , -- | The maximum header lines per mime/multipart entry
157+ prboMaxHeaderLines :: Maybe Int
158+ , -- | The maximum header line length per mime/multipart entry
159+ prboMaxHeaderLineLength :: Maybe Int }
160+
161+-- | Set the maximum length of a filename.
162+setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
163+setMaxRequestKeyLength l p = p { prboKeyLength=Just l }
164+
165+-- | Do not limit the length of filenames.
166+clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
167+clearMaxRequestKeyLength p = p { prboKeyLength=Nothing }
168+
169+-- | Set the maximum number of files per request.
170+setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
171+setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l }
172+
173+-- | Do not limit the maximum number of files per request.
174+clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
175+clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing }
176+
177+-- | Set the maximum filesize per file.
178+setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
179+setMaxRequestFileSize l p = p { prboMaxFileSize=Just l }
180+
181+-- | Do not limit the maximum filesize per file.
182+clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
183+clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing }
184+
185+-- | Set the maximum size of all files per request.
186+setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
187+setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l }
188+
189+-- | Do not limit the maximum size of all files per request.
190+clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
191+clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing }
192+
193+-- | Set the maximum size of the sum of all parameters.
194+setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
195+setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l }
196+
197+-- | Do not limit the maximum size of the sum of all parameters.
198+clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
199+clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing }
200+
201+-- | Set the maximum header lines per mime/multipart entry.
202+setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
203+setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l }
204+
205+-- | Do not limit the maximum header lines per mime/multipart entry.
206+clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions
207+clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing }
208+
209+-- | Set the maximum header line length per mime/multipart entry.
210+setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
211+setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l }
212+
213+-- | Do not limit the maximum header lines per mime/multipart entry.
214+clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
215+clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }
216+
217+-- | A reasonable default set of parsing options.
218+-- Maximum key/filename length: 32 bytes;
219+-- maximum files: 10; filesize unlimited; maximum
220+-- size for parameters: 64kbytes; maximum number of header
221+-- lines: 32 bytes (applies only to headers of a mime/multipart message);
222+-- maximum header line length: Apache's default for that is 8190 bytes
223+-- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline)
224+-- so we're using that here as well.
225+defaultParseRequestBodyOptions :: ParseRequestBodyOptions
226+defaultParseRequestBodyOptions = ParseRequestBodyOptions
227+ { prboKeyLength=Just 32
228+ , prboMaxNumFiles=Just 10
229+ , prboMaxFileSize=Nothing
230+ , prboMaxFilesSize=Nothing
231+ , prboMaxParmsSize=Just 65336
232+ , prboMaxHeaderLines=Just 32
233+ , prboMaxHeaderLineLength=Just 8190 }
234+
235+-- | Do not impose any memory limits.
236+noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
237+noLimitParseRequestBodyOptions = ParseRequestBodyOptions
238+ { prboKeyLength=Nothing
239+ , prboMaxNumFiles=Nothing
240+ , prboMaxFileSize=Nothing
241+ , prboMaxFilesSize=Nothing
242+ , prboMaxParmsSize=Nothing
243+ , prboMaxHeaderLines=Nothing
244+ , prboMaxHeaderLineLength=Nothing }
118245
119246-- | Information on an uploaded file.
120247data FileInfo c = FileInfo
@@ -137,8 +264,16 @@ type BackEnd a = S.ByteString -- ^ parameter name
137264 -> IO S.ByteString
138265 -> IO a
139266
140−data RequestBodyType = UrlEncoded | Multipart S.ByteString
267+-- | The mimetype of the http body.
268+-- Depending on whether just parameters or parameters and files
269+-- are passed, one or the other mimetype should be used.
270+data RequestBodyType
271+ = -- | application/x-www-form-urlencoded (parameters only)
272+ UrlEncoded
273+ | -- | multipart/form-data (parameters and files)
274+ Multipart S.ByteString
141275
276+-- | Get the mimetype of the body of an http request.
142277getRequestBodyType :: Request -> Maybe RequestBodyType
143278getRequestBodyType req = do
144279 ctype' <- lookup hContentType $ requestHeaders req
@@ -172,76 +307,125 @@ parseContentType a = do
172307 in (strip k, strip v)
173308 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
174309
310+-- | Parse the body of an HTTP request.
311+-- See parseRequestBodyEx for details.
312+-- Note: This function does not limit the memory it allocates.
313+-- When dealing with untrusted data (as is usually the case when
314+-- receiving input from the internet), it is recommended to
315+-- use the parseRequestBodyEx function instead.
175316parseRequestBody :: BackEnd y
176317 -> Request
177318 -> IO ([Param], [File y])
178−parseRequestBody s r =
319+parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions
320+
321+-- | Parse the body of an HTTP request, limit resource usage.
322+-- The HTTP body can contain both parameters and files.
323+-- This function will return a list of key,value pairs
324+-- for all parameters, and a list of key,a pairs
325+-- for filenames. The a depends on the used backend that
326+-- is responsible for storing the received files.
327+parseRequestBodyEx :: ParseRequestBodyOptions
328+ -> BackEnd y
329+ -> Request
330+ -> IO ([Param], [File y])
331+parseRequestBodyEx o s r =
179332 case getRequestBodyType r of
180333 Nothing -> return ([], [])
181− Just rbt -> sinkRequestBody s rbt (requestBody r)
334+ Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
182335
183336sinkRequestBody :: BackEnd y
184337 -> RequestBodyType
185338 -> IO S.ByteString
186339 -> IO ([Param], [File y])
187−sinkRequestBody s r body = do
188− ref <- newIORef (id, id)
340+sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
341+
342+sinkRequestBodyEx :: ParseRequestBodyOptions
343+ -> BackEnd y
344+ -> RequestBodyType
345+ -> IO S.ByteString
346+ -> IO ([Param], [File y])
347+sinkRequestBodyEx o s r body = do
348+ ref <- newIORef ([], [])
189349 let add x = atomicModifyIORef ref $ \(y, z) ->
190350 case x of
191− Left y' -> ((y . (y':), z), ())
192− Right z' -> ((y, z . (z':)), ())
193− conduitRequestBody s r body add
194− (x, y) <- readIORef ref
195− return (x [], y [])
196−
197−conduitRequestBody :: BackEnd y
198− -> RequestBodyType
199− -> IO S.ByteString
200− -> (Either Param (File y) -> IO ())
201− -> IO ()
202−conduitRequestBody _ UrlEncoded rbody add = do
351+ Left y' -> ((y':y, z), ())
352+ Right z' -> ((y, z':z), ())
353+ conduitRequestBodyEx o s r body add
354+ (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref
355+
356+conduitRequestBodyEx :: ParseRequestBodyOptions
357+ -> BackEnd y
358+ -> RequestBodyType
359+ -> IO S.ByteString
360+ -> (Either Param (File y) -> IO ())
361+ -> IO ()
362+conduitRequestBodyEx o _ UrlEncoded rbody add = do
203363 -- NOTE: in general, url-encoded data will be in a single chunk.
204364 -- Therefore, I'm optimizing for the usual case by sticking with
205365 -- strict byte strings here.
206− let loop front = do
366+ let loop size front = do
207367 bs <- rbody
208368 if S.null bs
209369 then return $ S.concat $ front []
210− else loop $ front . (bs:)
211− bs <- loop id
370+ else do
371+ let newsize = size + S.length bs
372+ case prboMaxParmsSize o of
373+ Just maxSize -> when (newsize > maxSize) $
374+ error "Maximum size of parameters exceeded"
375+ Nothing -> return ()
376+ loop newsize $ front . (bs:)
377+ bs <- loop 0 id
212378 mapM_ (add . Left) $ H.parseSimpleQuery bs
213−conduitRequestBody backend (Multipart bound) rbody add =
214− parsePieces backend (S8.pack "--" `S.append` bound) rbody add
379+conduitRequestBodyEx o backend (Multipart bound) rbody add =
380+ parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add
381+
215382
216−takeLine :: Source -> IO (Maybe S.ByteString)
217−takeLine src =
218− go id
383+-- | Take one header or subheader line.
384+takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
385+takeLine maxlen src =
386+ go ""
219387 where
220388 go front = do
221389 bs <- readSource src
390+ case maxlen of
391+ Just maxlen' -> when (S.length front + S.length bs > maxlen') $
392+ error "Header line length exceeds allowed maximum."
393+ Nothing -> return ()
222394 if S.null bs
223395 then close front
224396 else push front bs
225397
226− close front = leftover src (front S.empty) >> return Nothing
398+ close front = leftover src front >> return Nothing
227399 push front bs = do
228− let (x, y) = S.break (== 10) $ front bs -- LF
400+ let (x, y) = S.break (== 10) bs -- LF
229401 in if S.null y
230− then go $ S.append x
402+ then go $ front `S.append` x
231403 else do
232404 when (S.length y > 1) $ leftover src $ S.drop 1 y
233− return $ Just $ killCR x
234−
235−takeLines :: Source -> IO [S.ByteString]
236−takeLines src = do
237− res <- takeLine src
405+ return $ Just $ killCR $ front `S.append` x
406+
407+takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
408+takeLines' lineLength maxLines source =
409+ reverse <$> takeLines'' [] lineLength maxLines source
410+
411+takeLines''
412+ :: [S.ByteString]
413+ -> Maybe Int
414+ -> Maybe Int
415+ -> Source
416+ -> IO [S.ByteString]
417+takeLines'' lines lineLength maxLines src = do
418+ case maxLines of
419+ Just maxLines' ->
420+ when (length lines > maxLines') $
421+ error "Too many lines in mime/multipart header"
422+ Nothing -> return ()
423+ res <- takeLine lineLength src
238424 case res of
239− Nothing -> return []
425+ Nothing -> return lines
240426 Just l
241− | S.null l -> return []
242− | otherwise -> do
243− ls <- takeLines src
244− return $ l : ls
427+ | S.null l -> return lines
428+ | otherwise -> takeLines'' (l:lines) lineLength maxLines src
245429
246430data Source = Source (IO S.ByteString) (IORef S.ByteString)
247431
@@ -260,17 +444,20 @@ readSource (Source f ref) = do
260444leftover :: Source -> S.ByteString -> IO ()
261445leftover (Source _ ref) bs = writeIORef ref bs
262446
263−parsePieces :: BackEnd y
264− -> S.ByteString
265− -> IO S.ByteString
266− -> (Either Param (File y) -> IO ())
267− -> IO ()
268−parsePieces sink bound rbody add =
269− mkSource rbody >>= loop
447+parsePiecesEx :: ParseRequestBodyOptions
448+ -> BackEnd y
449+ -> S.ByteString
450+ -> IO S.ByteString
451+ -> (Either Param (File y) -> IO ())
452+ -> IO ()
453+parsePiecesEx o sink bound rbody add =
454+ mkSource rbody >>= loop 0 0 0 0
270455 where
271− loop src = do
272− _boundLine <- takeLine src
273− res' <- takeLines src
456+ loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
457+ loop numParms numFiles parmSize filesSize src = do
458+ _boundLine <- takeLine (prboMaxHeaderLineLength o) src
459+ res' <- takeLines' (prboMaxHeaderLineLength o)
460+ (prboMaxHeaderLines o) src
274461 unless (null res') $ do
275462 let ls' = map parsePair res'
276463 let x = do
@@ -281,25 +468,50 @@ parsePieces sink bound rbody add =
281468 return (ct, name, lookup "filename" attrs)
282469 case x of
283470 Just (mct, name, Just filename) -> do
471+ case prboKeyLength o of
472+ Just maxKeyLength ->
473+ when (S.length name > maxKeyLength) $
474+ error "Filename is too long"
475+ Nothing -> return ()
476+ case prboMaxNumFiles o of
477+ Just maxFiles -> when (numFiles >= maxFiles) $
478+ error "Maximum number of files exceeded"
479+ Nothing -> return ()
284480 let ct = fromMaybe "application/octet-stream" mct
285481 fi0 = FileInfo filename ct ()
286− (wasFound, y) <- sinkTillBound' bound name fi0 sink src
482+ fs = catMaybes [ prboMaxFileSize o
483+ , subtract filesSize <$> prboMaxFilesSize o ]
484+ mfs = if fs == [] then Nothing else Just $ minimum fs
485+ ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
486+ let newFilesSize = filesSize + fileSize
287487 add $ Right (name, fi0 { fileContent = y })
288− when wasFound (loop src)
488+ when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
289489 Just (_ct, name, Nothing) -> do
490+ case prboKeyLength o of
491+ Just maxKeyLength ->
492+ when (S.length name > maxKeyLength) $
493+ error "Parameter name is too long"
494+ Nothing -> return ()
290495 let seed = id
291496 let iter front bs = return $ front . (:) bs
292− (wasFound, front) <- sinkTillBound bound iter seed src
497+ ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src
498+ (fromIntegral <$> prboMaxParmsSize o)
293499 let bs = S.concat $ front []
294500 let x' = (name, bs)
501+ let newParmSize = parmSize + S.length name + S.length bs
502+ case prboMaxParmsSize o of
503+ Just maxParmSize -> when (newParmSize > maxParmSize) $
504+ error "Maximum size of parameters exceeded"
505+ Nothing -> return ()
295506 add $ Left x'
296− when wasFound (loop src)
507+ when wasFound $ loop (numParms + 1) numFiles
508+ newParmSize filesSize src
297509 _ -> do
298510 -- ignore this part
299511 let seed = ()
300512 iter () _ = return ()
301− (wasFound, ()) <- sinkTillBound bound iter seed src
302− when wasFound (loop src)
513+ ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
514+ when wasFound $ loop numParms numFiles parmSize filesSize src
303515 where
304516 contDisp = mk $ S8.pack "Content-Disposition"
305517 contType = mk $ S8.pack "Content-Type"
@@ -307,6 +519,7 @@ parsePieces sink bound rbody add =
307519 let (x, y) = breakDiscard 58 s -- colon
308520 in (mk $ x, S.dropWhile (== 32) y) -- space
309521
522+
310523data Bound = FoundBound S.ByteString S.ByteString
311524 | NoBound
312525 | PartialBound
@@ -340,9 +553,10 @@ sinkTillBound' :: S.ByteString
340553 -> FileInfo ()
341554 -> BackEnd y
342555 -> Source
343− -> IO (Bool, y)
344−sinkTillBound' bound name fi sink src = do
345− (next, final) <- wrapTillBound bound src
556+ -> Maybe Int64
557+ -> IO ((Bool, Int64), y)
558+sinkTillBound' bound name fi sink src max' = do
559+ (next, final) <- wrapTillBound bound src max'
346560 y <- sink name fi next
347561 b <- final
348562 return (b, y)
@@ -351,23 +565,32 @@ data WTB = WTBWorking (S.ByteString -> S.ByteString)
351565 | WTBDone Bool
352566wrapTillBound :: S.ByteString -- ^ bound
353567 -> Source
354− -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found
355−wrapTillBound bound src = do
568+ -> Maybe Int64
569+ -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found
570+wrapTillBound bound src max' = do
356571 ref <- newIORef $ WTBWorking id
357− return (go ref, final ref)
572+ sref <- newIORef (0 :: Int64)
573+ return (go ref sref, final ref sref)
358574 where
359− final ref = do
575+ final ref sref = do
360576 x <- readIORef ref
361577 case x of
362578 WTBWorking _ -> error "wrapTillBound did not finish"
363− WTBDone y -> return y
579+ WTBDone y -> do
580+ siz <- readIORef sref
581+ return (y, siz)
364582
365− go ref = do
583+ go ref sref = do
366584 state <- readIORef ref
367585 case state of
368586 WTBDone _ -> return S.empty
369587 WTBWorking front -> do
370588 bs <- readSource src
589+ cur <- atomicModifyIORef' sref $ \ cur ->
590+ let new = cur + fromIntegral (S.length bs) in (new, new)
591+ case max' of
592+ Just max'' | cur > max'' -> error "Maximum size exceeded"
593+ _ -> return ()
371594 if S.null bs
372595 then do
373596 writeIORef ref $ WTBDone False
@@ -390,19 +613,20 @@ wrapTillBound bound src = do
390613 else (bs, id)
391614 writeIORef ref $ WTBWorking front'
392615 if S.null toEmit
393− then go ref
616+ then go ref sref
394617 else return toEmit
395618 PartialBound -> do
396619 writeIORef ref $ WTBWorking $ S.append bs
397− go ref
620+ go ref sref
398621
399622sinkTillBound :: S.ByteString
400623 -> (x -> S.ByteString -> IO x)
401624 -> x
402625 -> Source
403− -> IO (Bool, x)
404−sinkTillBound bound iter seed0 src = do
405− (next, final) <- wrapTillBound bound src
626+ -> Maybe Int64
627+ -> IO ((Bool, Int64), x)
628+sinkTillBound bound iter seed0 src max' = do
629+ (next, final) <- wrapTillBound bound src max'
406630 let loop seed = do
407631 bs <- next
408632 if S.null bs