@@ -1,5 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ExistentialQuantification #-}
2{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE PatternGuards #-}
3{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
@@ -12,7 +11,7 @@ module Network.Wai.Parse
12 , RequestBodyType (..)
11 , RequestBodyType (..)
13 , getRequestBodyType
12 , getRequestBodyType
14 , sinkRequestBody
13 , sinkRequestBody
15− , conduitRequestBody
14+ , sinkRequestBodyEx
17 , lbsBackEnd
16 , lbsBackEnd
18 , tempFileBackEnd
17 , tempFileBackEnd
@@ -21,6 +20,24 @@ module Network.Wai.Parse
22 , FileInfo (..)
21 , FileInfo (..)
23 , 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
25 , Bound (..)
42 , Bound (..)
26 , findBound
43 , findBound
@@ -31,31 +48,30 @@ module Network.Wai.Parse
34−import qualified Data.ByteString.Search as Search
51+import qualified Control.Exception as E
35import qualified Data.ByteString as S
52import qualified Data.ByteString as S
36import qualified Data.ByteString.Lazy as L
53import qualified Data.ByteString.Lazy as L
37import qualified Data.ByteString.Char8 as S8
54import qualified Data.ByteString.Char8 as S8
38import Data.Word (Word8)
55import Data.Word (Word8)
56+import Data.Int (Int64)
39−import Data.Maybe (fromMaybe)
57+import Data.Maybe (catMaybes, fromMaybe)
40import Data.List (sortBy)
58import Data.List (sortBy)
41−import Data.Function (on)
59+import Data.Function (on, fix)
42import System.Directory (removeFile, getTemporaryDirectory)
60import System.Directory (removeFile, getTemporaryDirectory)
43import System.IO (hClose, openBinaryTempFile)
61import System.IO (hClose, openBinaryTempFile)
62+import System.IO.Error (isDoesNotExistError)
44import Network.Wai
63import Network.Wai
46−import Data.Conduit.Internal ()
47−import qualified Data.Conduit.List as CL
48−import qualified Data.Conduit.Binary as CB
49−import Control.Monad.IO.Class (liftIO)
50import qualified Network.HTTP.Types as H
64import qualified Network.HTTP.Types as H
51−import Data.Either (partitionEithers)
65+import Control.Applicative ((<$>))
66+import Control.Exception (catchJust)
52−import Control.Monad (when, unless)
67+import Control.Monad (when, unless, guard)
53−import Control.Monad.Trans.Class (lift)
54−import Control.Monad.Trans.Resource (allocate, release, register)
68+import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
55−#if MIN_VERSION_conduit(1, 0, 0)
69+import Data.IORef
56−import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..))
70+import Network.HTTP.Types (hContentType)
71+import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
57−import Data.Void (Void)
72+import Data.CaseInsensitive (mk)
74+import Prelude hiding (lines)
60breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
76breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
61breakDiscard w s =
77breakDiscard w s =
@@ -87,28 +103,186 @@ parseHttpAccept = map fst
89-- | Store uploaded files in memory
105-- | Store uploaded files in memory
90−lbsBackEnd :: Monad m => ignored1 -> ignored2 -> Sink S.ByteString m L.ByteString
106+lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString
91−lbsBackEnd _ _ = fmap L.fromChunks CL.consume
107+lbsBackEnd _ _ popper =
113+ then return $ L.fromChunks $ front []
114+ else loop $ front . (bs:)
93-- | Save uploaded files on disk as temporary files
116-- | Save uploaded files on disk as temporary files
118+-- Note: starting with version 2.0, removal of temp files is registered with
119+-- the provided @InternalState@. It is the responsibility of the caller to
120+-- ensure that this @InternalState@ gets cleaned up.
94−tempFileBackEnd :: MonadResource m => ignored1 -> ignored2 -> Sink S.ByteString m FilePath
121+tempFileBackEnd :: 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.
98−tempFileBackEndOpts :: MonadResource m
99− => IO FilePath -- ^ get temporary directory
125+tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
100 -> String -- ^ filename pattern
126 -> String -- ^ filename pattern
101 -> ignored1
128 -> ignored1
102 -> ignored2
129 -> ignored2
103− -> Sink S.ByteString m FilePath
130+ -> IO S.ByteString
104−tempFileBackEndOpts getTmpDir pattern _ _ = do
132+tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
105− (key, (fp, h)) <- lift $ allocate (do
133+ (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
106− tempDir <- getTmpDir
134+ _ <- runInternalState (register $ removeFileQuiet fp) internalState
107− openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)
135+ fix $ \loop -> do
108− _ <- lift $ register $ removeFile fp
136+ bs <- popper
109− CB.sinkHandle h
137+ unless (S.null bs) $ do
110− lift $ release key
140+ release key
111 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 }
113-- | Information on an uploaded file.
287-- | Information on an uploaded file.
114data FileInfo c = FileInfo
288data FileInfo c = FileInfo
@@ -124,17 +298,26 @@ type Param = (S.ByteString, S.ByteString)
124-- | Post parameter name and associated file information.
298-- | Post parameter name and associated file information.
125type File y = (S.ByteString, FileInfo y)
299type File y = (S.ByteString, FileInfo y)
127−-- | A file uploading backend. Takes the parameter name, file name, and content
301+-- | A file uploading backend. Takes the parameter name, file name, and a
128−-- type, and returns a `Sink` for storing the contents.
302+-- stream of data.
129type BackEnd a = S.ByteString -- ^ parameter name
303type BackEnd a = S.ByteString -- ^ parameter name
130 -> FileInfo ()
304 -> FileInfo ()
131− -> Sink S.ByteString (ResourceT IO) a
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)
133−data RequestBodyType = UrlEncoded | Multipart S.ByteString
315+ Multipart S.ByteString
317+-- | Get the mimetype of the body of an http request.
135getRequestBodyType :: Request -> Maybe RequestBodyType
318getRequestBodyType :: Request -> Maybe RequestBodyType
136getRequestBodyType req = do
319getRequestBodyType req = do
137− ctype' <- lookup "Content-Type" $ requestHeaders req
320+ ctype' <- lookup hContentType $ requestHeaders req
138 let (ctype, attrs) = parseContentType ctype'
321 let (ctype, attrs) = parseContentType ctype'
139 case ctype of
322 case ctype of
140 "application/x-www-form-urlencoded" -> return UrlEncoded
323 "application/x-www-form-urlencoded" -> return UrlEncoded
@@ -144,7 +327,7 @@ getRequestBodyType req = do
144-- | 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
145-- content type and a list of pairs of attributes.
328-- content type and a list of pairs of attributes.
147−-- Since 1.3.2
330+-- @since 1.3.2
148parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
331parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
149parseContentType a = do
332parseContentType a = do
150 let (ctype, b) = S.break (== semicolon) a
333 let (ctype, b) = S.break (== semicolon) a
@@ -154,6 +337,9 @@ parseContentType a = do
154 semicolon = 59
337 semicolon = 59
155 equals = 61
338 equals = 61
156 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
157 goAttrs front bs
343 goAttrs front bs
158 | S.null bs = front []
344 | S.null bs = front []
159 | otherwise =
345 | otherwise =
@@ -162,81 +348,172 @@ parseContentType a = do
162 goAttr bs =
348 goAttr bs =
163 let (k, v') = S.break (== equals) bs
349 let (k, v') = S.break (== equals) bs
164 v = S.drop 1 v'
350 v = S.drop 1 v'
165− in (strip k, strip v)
351+ in (strip k, dq $ strip v)
166 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.
168parseRequestBody :: BackEnd y
360parseRequestBody :: BackEnd y
169 -> Request
361 -> Request
170− -> ResourceT IO ([Param], [File y])
362+ -> IO ([Param], [File y])
171−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 =
172 case getRequestBodyType r of
376 case getRequestBodyType r of
173 Nothing -> return ([], [])
377 Nothing -> return ([], [])
174− Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume
378+ Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
176sinkRequestBody :: BackEnd y
380sinkRequestBody :: BackEnd y
177 -> RequestBodyType
381 -> RequestBodyType
178− -> Sink S.ByteString (ResourceT IO) ([Param], [File y])
383+ -> IO ([Param], [File y])
179−sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume
384+sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
389+sinkRequestBodyEx :: ParseRequestBodyOptions
181−conduitRequestBody :: BackEnd y
390+ -> BackEnd y
182− -> RequestBodyType
391+ -> RequestBodyType
393+ -> IO ([Param], [File y])
394+sinkRequestBodyEx o s r body = do
395+ ref <- newIORef ([], [])
396+ let add x = atomicModifyIORef ref $ \(y, z) ->
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
403+conduitRequestBodyEx :: ParseRequestBodyOptions
183− -> Conduit S.ByteString (ResourceT IO) (Either Param (File y))
407+ -> (Either Param (File y) -> IO ())
184−conduitRequestBody _ UrlEncoded = do
408+ -> IO ()
409+conduitRequestBodyEx o _ UrlEncoded rbody add = do
185 -- 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.
186 -- Therefore, I'm optimizing for the usual case by sticking with
411 -- Therefore, I'm optimizing for the usual case by sticking with
187 -- strict byte strings here.
412 -- strict byte strings here.
188− bs <- CL.consume
413+ let loop size front = do
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 ()
423+ loop newsize $ front . (bs:)
189− mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs
425+ mapM_ (add . Left) $ H.parseSimpleQuery bs
190−conduitRequestBody backend (Multipart bound) =
426+conduitRequestBodyEx o backend (Multipart bound) rbody add =
191− parsePieces backend $ S8.pack "--" `S.append` bound
427+ parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add
193−#if MIN_VERSION_conduit(1, 0, 0)
429+
194−takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString)
430+-- | Take one header or subheader line.
195−#else
431+-- Since: 3.0.26
432+-- Throw 431 if headers too large.
196−takeLine :: Monad m => Pipe S.ByteString S.ByteString o u m (Maybe S.ByteString)
433+takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
198−takeLine =
434+takeLine maxlen src =
201− go front = await >>= maybe (close front) (push front)
437+ go front = do
202−
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 ()
203− close front = leftover (front S.empty) >> return Nothing
448+ close front = leftover src front >> return Nothing
204 push front bs = do
449 push front bs = do
205− let (x, y) = S.break (== 10) $ front bs -- LF
450+ let (x, y) = S.break (== 10) bs -- LF
206 in if S.null y
451 in if S.null y
207− then go $ S.append x
452+ then go $ front `S.append` x
209− when (S.length y > 1) $ leftover $ S.drop 1 y
454+ when (S.length y > 1) $ leftover src $ S.drop 1 y
210− return $ Just $ killCR x
455+ let res = front `S.append` x
212−#if MIN_VERSION_conduit(1, 0, 0)
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
213−takeLines :: Consumer S.ByteString (ResourceT IO) [S.ByteString]
463+takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
214−#else
464+takeLines' lineLength maxLines source =
215−takeLines :: Pipe S.ByteString S.ByteString o u (ResourceT IO) [S.ByteString]
465+ reverse <$> takeLines'' [] lineLength maxLines source
472+ -> IO [S.ByteString]
217−takeLines = do
473+takeLines'' lines lineLength maxLines src = do
476+ when (length lines > maxLines') $
477+ error "Too many lines in mime/multipart header"
478+ Nothing -> return ()
218− res <- takeLine
479+ res <- takeLine lineLength src
219 case res of
480 case res of
220− Nothing -> return []
481+ Nothing -> return lines
222− | S.null l -> return []
483+ | S.null l -> return lines
223− | otherwise -> do
484+ | otherwise -> takeLines'' (l:lines) lineLength maxLines src
225− return $ l : ls
486+data Source = Source (IO S.ByteString) (IORef S.ByteString)
227−parsePieces :: BackEnd y
488+mkSource :: IO S.ByteString -> IO Source
490+ ref <- newIORef S.empty
491+ return $ Source f ref
228− -> S.ByteString
493+readSource :: Source -> IO S.ByteString
229−#if MIN_VERSION_conduit(1, 0, 0)
494+readSource (Source f ref) = do
230− -> ConduitM S.ByteString (Either Param (File y)) (ResourceT IO) ()
495+ bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs)
231−#else
498+ else return bs
500+leftover :: Source -> S.ByteString -> IO ()
501+leftover (Source _ ref) bs = writeIORef ref bs
503+parsePiecesEx :: ParseRequestBodyOptions
232− -> Pipe S.ByteString S.ByteString (Either Param (File y)) u (ResourceT IO) ()
507+ -> (Either Param (File y) -> IO ())
234−parsePieces sink bound =
509+parsePiecesEx o sink bound rbody add =
235− loop
510+ mkSource rbody >>= loop 0 0 0 0
237− loop = do
512+ loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
513+ loop numParms numFiles parmSize filesSize src = do
238− _boundLine <- takeLine
514+ _boundLine <- takeLine (prboMaxHeaderLineLength o) src
239− res' <- takeLines
515+ res' <- takeLines' (prboMaxHeaderLineLength o)
516+ (prboMaxHeaderLines o) src
240 unless (null res') $ do
517 unless (null res') $ do
241 let ls' = map parsePair res'
518 let ls' = map parsePair res'
242 let x = do
519 let x = do
@@ -247,31 +524,57 @@ parsePieces sink bound =
247 return (ct, name, lookup "filename" attrs)
524 return (ct, name, lookup "filename" attrs)
248 case x of
525 case x of
249 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 ()
250 let ct = fromMaybe "application/octet-stream" mct
536 let ct = fromMaybe "application/octet-stream" mct
251 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
252− (wasFound, y) <- sinkTillBound' bound name fi0 sink
541+ ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
542+ let newFilesSize = filesSize + fileSize
253− yield $ Right (name, fi0 { fileContent = y })
543+ add $ Right (name, fi0 { fileContent = y })
254− when wasFound loop
544+ when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
255 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 ()
256 let seed = id
551 let seed = id
257 let iter front bs = return $ front . (:) bs
552 let iter front bs = return $ front . (:) bs
258− (wasFound, front) <- sinkTillBound bound iter seed
553+ ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src
554+ (fromIntegral <$> prboMaxParmsSize o)
259 let bs = S.concat $ front []
555 let bs = S.concat $ front []
260 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 ()
261− yield $ Left x'
562+ add $ Left x'
262− when wasFound loop
563+ when wasFound $ loop (numParms + 1) numFiles
564+ newParmSize filesSize src
264 -- ignore this part
566 -- ignore this part
265 let seed = ()
567 let seed = ()
266 iter () _ = return ()
568 iter () _ = return ()
267− (wasFound, ()) <- sinkTillBound bound iter seed
569+ ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
268− when wasFound loop
570+ when wasFound $ loop numParms numFiles parmSize filesSize src
270− contDisp = S8.pack "Content-Disposition"
572+ contDisp = mk $ S8.pack "Content-Disposition"
271− contType = S8.pack "Content-Type"
573+ contType = mk $ S8.pack "Content-Type"
272 parsePair s =
574 parsePair s =
273 let (x, y) = breakDiscard 58 s -- colon
575 let (x, y) = breakDiscard 58 s -- colon
274− in (x, S.dropWhile (== 32) y) -- space
576+ in (mk $ x, S.dropWhile (== 32) y) -- space
276data Bound = FoundBound S.ByteString S.ByteString
579data Bound = FoundBound S.ByteString S.ByteString
277 | NoBound
580 | NoBound
@@ -279,7 +582,7 @@ data Bound = FoundBound S.ByteString S.ByteString
279 deriving (Eq, Show)
582 deriving (Eq, Show)
281findBound :: S.ByteString -> S.ByteString -> Bound
584findBound :: S.ByteString -> S.ByteString -> Bound
282−findBound b bs = handleBreak $ Search.breakOn b bs
585+findBound b bs = handleBreak $ S.breakSubstring b bs
284 handleBreak (h, t)
587 handleBreak (h, t)
285 | S.null t = go [lowBound..S.length bs - 1]
588 | S.null t = go [lowBound..S.length bs - 1]
@@ -305,90 +608,90 @@ sinkTillBound' :: S.ByteString
305 -> S.ByteString
608 -> S.ByteString
306 -> FileInfo ()
609 -> FileInfo ()
307 -> BackEnd y
610 -> BackEnd y
308−#if MIN_VERSION_conduit(1, 0, 0)
611+ -> Source
309− -> ConduitM S.ByteString o (ResourceT IO) (Bool, y)
612+ -> Maybe Int64
310−#else
613+ -> IO ((Bool, Int64), y)
311− -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, y)
313−sinkTillBound' bound name fi sink =
614+sinkTillBound' bound name fi sink src max' = do
314−#if MIN_VERSION_conduit(1, 0, 0)
615+ (next, final) <- wrapTillBound bound src max'
315− ConduitM $ anyOutput $
616+ y <- sink name fi next
316−#endif
617+ b <- final
317− conduitTillBound bound >+> withUpstream (fix $ sink name fi)
618+ return (b, y)
620+data WTB = WTBWorking (S.ByteString -> S.ByteString)
622+wrapTillBound :: S.ByteString -- ^ bound
625+ -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found
626+wrapTillBound bound src max' = do
627+ ref <- newIORef $ WTBWorking id
628+ sref <- newIORef (0 :: Int64)
629+ return (go ref sref, final ref sref)
319−#if MIN_VERSION_conduit(1, 0, 0)
631+ final ref sref = do
320− fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool (ResourceT IO) y
632+ x <- readIORef ref
321− fix (ConduitM p) = ignoreTerm >+> injectLeftovers p
633+ case x of
322− ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)
634+ WTBWorking _ -> error "wrapTillBound did not finish"
323− await' = NeedInput (return . Just) (const $ return Nothing)
635+ WTBDone y -> do
324− yield' = HaveOutput (return ()) (return ())
636+ siz <- readIORef sref
326− anyOutput p = p >+> dropInput
638+
327− dropInput = NeedInput (const dropInput) return
639+ go ref sref = do
328−#else
640+ state <- readIORef ref
329− fix = sinkToPipe
641+ case state of
330−#endif
642+ WTBDone _ -> return S.empty
331−
643+ WTBWorking front -> do
332−conduitTillBound :: Monad m
644+ bs <- readSource src
333− => S.ByteString -- bound
645+ cur <- atomicModifyIORef' sref $ \ cur ->
334−#if MIN_VERSION_conduit(1, 0, 0)
646+ let new = cur + fromIntegral (S.length bs) in (new, new)
335− -> Pipe S.ByteString S.ByteString S.ByteString () m Bool
647+ case max' of
336−#else
648+ Just max'' | cur > max'' ->
337− -> Pipe S.ByteString S.ByteString S.ByteString u m Bool
649+ E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"
338−#endif
650+ _ -> return ()
339−conduitTillBound bound =
651+ if S.null bs
340−#if MIN_VERSION_conduit(1, 0, 0)
652+ then do
341− unConduitM $
653+ writeIORef ref $ WTBDone False
345− go front = await >>= maybe (close front) (push front)
347− let bs = front S.empty
348− unless (S.null bs) $ yield bs
350− push front bs' = do
654+ return $ front bs
351− let bs = front bs'
655+ else push $ front bs
352− case findBound bound bs of
658+ case findBound bound bs of
353− FoundBound before after -> do
659+ FoundBound before after -> do
354− let before' = killCRLF before
660+ let before' = killCRLF before
356− leftover after
661+ leftover src after
357− return True
662+ writeIORef ref $ WTBDone True
358− NoBound -> do
664+ NoBound -> do
359− -- don't emit newlines, in case it's part of a bound
665+ -- don't emit newlines, in case it's part of a bound
360− let (toEmit, front') =
666+ let (toEmit, front') =
361− if not (S8.null bs) && S8.last bs `elem` "\r\n"
667+ if not (S8.null bs) && S8.last bs `elem` ['\r','\n']
362− then let (x, y) = S.splitAt (S.length bs - 2) bs
668+ then let (x, y) = S.splitAt (S.length bs - 2) bs
363− in (x, S.append y)
669+ in (x, S.append y)
364− else (bs, id)
670+ else (bs, id)
671+ writeIORef ref $ WTBWorking front'
365− yield toEmit
672+ if S.null toEmit
366− go front'
673+ then go ref sref
367− PartialBound -> go $ S.append bs
675+ PartialBound -> do
676+ writeIORef ref $ WTBWorking $ S.append bs
369sinkTillBound :: S.ByteString
679sinkTillBound :: S.ByteString
370 -> (x -> S.ByteString -> IO x)
680 -> (x -> S.ByteString -> IO x)
372−#if MIN_VERSION_conduit(1, 0, 0)
682+ -> Source
373− -> Consumer S.ByteString (ResourceT IO) (Bool, x)
683+ -> Maybe Int64
374−#else
684+ -> IO ((Bool, Int64), x)
375− -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, x)
377−sinkTillBound bound iter seed0 =
685+sinkTillBound bound iter seed0 src max' = do
378−#if MIN_VERSION_conduit(1, 0, 0)
686+ (next, final) <- wrapTillBound bound src max'
379− ConduitM $
687+ let loop seed = do
380−#endif
688+ bs <- next
381− (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0))
689+ if S.null bs
382− where
690+ then return seed
383− iter' a b = liftIO $ iter a b
691+ else iter seed bs >>= loop
384−#if MIN_VERSION_conduit(1, 0, 0)
692+ seed <- loop seed0
385− ij (ConduitM p) = ignoreTerm >+> injectLeftovers p
693+ b <- final
386− ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)
694+ return (b, seed)
387− await' = NeedInput (return . Just) (const $ return Nothing)
388− yield' = HaveOutput (return ()) (return ())
393parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
696parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
394parseAttrs = map go . S.split 59 -- semicolon
697parseAttrs = map go . S.split 59 -- semicolon