@@ -1,8 +1,8 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
23{-# LANGUAGE ExistentialQuantification #-}
34{-# LANGUAGE PatternGuards #-}
45{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE RankNTypes #-}
66-- | Some helpers for parsing data out of a raw WAI 'Request'.
77
88module Network.Wai.Parse
@@ -11,7 +11,7 @@ module Network.Wai.Parse
1111 , RequestBodyType (..)
1212 , getRequestBodyType
1313 , sinkRequestBody
14− , sinkRequestBodyEx
14+ , conduitRequestBody
1515 , BackEnd
1616 , lbsBackEnd
1717 , tempFileBackEnd
@@ -20,24 +20,6 @@ module Network.Wai.Parse
2020 , File
2121 , FileInfo (..)
2222 , parseContentType
23− , ParseRequestBodyOptions
24− , defaultParseRequestBodyOptions
25− , noLimitParseRequestBodyOptions
26− , parseRequestBodyEx
27− , setMaxRequestKeyLength
28− , clearMaxRequestKeyLength
29− , setMaxRequestNumFiles
30− , clearMaxRequestNumFiles
31− , setMaxRequestFileSize
32− , clearMaxRequestFileSize
33− , setMaxRequestFilesSize
34− , clearMaxRequestFilesSize
35− , setMaxRequestParmsSize
36− , clearMaxRequestParmsSize
37− , setMaxHeaderLines
38− , clearMaxHeaderLines
39− , setMaxHeaderLineLength
40− , clearMaxHeaderLineLength
4123#if TEST
4224 , Bound (..)
4325 , findBound
@@ -48,30 +30,31 @@ module Network.Wai.Parse
4830#endif
4931 ) where
5032
51−import qualified Control.Exception as E
33+import qualified Data.ByteString.Search as Search
5234import qualified Data.ByteString as S
5335import qualified Data.ByteString.Lazy as L
5436import qualified Data.ByteString.Char8 as S8
5537import Data.Word (Word8)
56−import Data.Int (Int64)
57−import Data.Maybe (catMaybes, fromMaybe)
38+import Data.Maybe (fromMaybe)
5839import Data.List (sortBy)
59−import Data.Function (on, fix)
40+import Data.Function (on)
6041import System.Directory (removeFile, getTemporaryDirectory)
6142import System.IO (hClose, openBinaryTempFile)
62−import System.IO.Error (isDoesNotExistError)
6343import Network.Wai
44+import Data.Conduit
45+import Data.Conduit.Internal (sinkToPipe)
46+import qualified Data.Conduit.List as CL
47+import qualified Data.Conduit.Binary as CB
48+import Control.Monad.IO.Class (liftIO)
6449import qualified Network.HTTP.Types as H
65−import Control.Applicative ((<$>))
66−import Control.Exception (catchJust)
67−import Control.Monad (when, unless, guard)
68−import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
69−import Data.IORef
70−import Network.HTTP.Types (hContentType)
71−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
72−import Data.CaseInsensitive (mk)
73−
74−import Prelude hiding (lines)
50+import Data.Either (partitionEithers)
51+import Control.Monad (when, unless)
52+import Control.Monad.Trans.Class (lift)
53+import Control.Monad.Trans.Resource (allocate, release, register)
54+#if MIN_VERSION_conduit(1, 0, 0)
55+import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, Sink (..), injectLeftovers, ConduitM (..))
56+import Data.Void (Void)
57+#endif
7558
7659breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
7760breakDiscard w s =
@@ -103,186 +86,28 @@ parseHttpAccept = map fst
10386 _ -> 1.0
10487
10588-- | Store uploaded files in memory
106−lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString
107−lbsBackEnd _ _ popper =
108− loop id
109− where
110− loop front = do
111− bs <- popper
112− if S.null bs
113− then return $ L.fromChunks $ front []
114− else loop $ front . (bs:)
89+lbsBackEnd :: Monad m => ignored1 -> ignored2 -> Sink S.ByteString m L.ByteString
90+lbsBackEnd _ _ = fmap L.fromChunks CL.consume
11591
11692-- | Save uploaded files on disk as temporary files
117−--
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.
121−tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
93+tempFileBackEnd :: MonadResource m => ignored1 -> ignored2 -> Sink S.ByteString m FilePath
12294tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"
12395
124−-- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.
125−tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
96+-- | Same as 'tempFileSink', but use configurable temp folders and patterns.
97+tempFileBackEndOpts :: MonadResource m
98+ => IO FilePath -- ^ get temporary directory
12699 -> String -- ^ filename pattern
127− -> InternalState
128100 -> ignored1
129101 -> ignored2
130− -> IO S.ByteString
131− -> IO FilePath
132−tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
133− (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
134− _ <- runInternalState (register $ removeFileQuiet fp) internalState
135− fix $ \loop -> do
136− bs <- popper
137− unless (S.null bs) $ do
138− S.hPut h bs
139− loop
140− release key
102+ -> Sink S.ByteString m FilePath
103+tempFileBackEndOpts getTmpDir pattern _ _ = do
104+ (key, (fp, h)) <- lift $ allocate (do
105+ tempDir <- getTmpDir
106+ openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)
107+ _ <- lift $ register $ removeFile fp
108+ CB.sinkHandle h
109+ lift $ release key
141110 return fp
142− where
143− it = do
144− tempDir <- getTmpDir
145− openBinaryTempFile tempDir pattrn
146− removeFileQuiet fp = catchJust (guard . isDoesNotExistError)
147− (removeFile fp)
148− (const $ return ())
149−
150−-- | A data structure that describes the behavior of
151−-- the parseRequestBodyEx function.
152−--
153−-- @since 3.0.16.0
154−data ParseRequestBodyOptions = ParseRequestBodyOptions
155− { -- | The maximum length of a filename
156− prboKeyLength :: Maybe Int
157− , -- | The maximum number of files.
158− prboMaxNumFiles :: Maybe Int
159− , -- | The maximum filesize per file.
160− prboMaxFileSize :: Maybe Int64
161− , -- | The maximum total filesize.
162− prboMaxFilesSize :: Maybe Int64
163− , -- | The maximum size of the sum of all parameters
164− prboMaxParmsSize :: Maybe Int
165− , -- | The maximum header lines per mime/multipart entry
166− prboMaxHeaderLines :: Maybe Int
167− , -- | The maximum header line length per mime/multipart entry
168− prboMaxHeaderLineLength :: Maybe Int }
169−
170−-- | Set the maximum length of a filename.
171−--
172−-- @since 3.0.16.0
173−setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
174−setMaxRequestKeyLength l p = p { prboKeyLength=Just l }
175−
176−-- | Do not limit the length of filenames.
177−--
178−-- @since 3.0.16.0
179−clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
180−clearMaxRequestKeyLength p = p { prboKeyLength=Nothing }
181−
182−-- | Set the maximum number of files per request.
183−--
184−-- @since 3.0.16.0
185−setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
186−setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l }
187−
188−-- | Do not limit the maximum number of files per request.
189−--
190−-- @since 3.0.16.0
191−clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
192−clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing }
193−
194−-- | Set the maximum filesize per file (in bytes).
195−--
196−-- @since 3.0.16.0
197−setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
198−setMaxRequestFileSize l p = p { prboMaxFileSize=Just l }
199−
200−-- | Do not limit the maximum filesize per file.
201−--
202−-- @since 3.0.16.0
203−clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
204−clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing }
205−
206−-- | Set the maximum size of all files per request.
207−--
208−-- @since 3.0.16.0
209−setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
210−setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l }
211−
212−-- | Do not limit the maximum size of all files per request.
213−--
214−-- @since 3.0.16.0
215−clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
216−clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing }
217−
218−-- | Set the maximum size of the sum of all parameters.
219−--
220−-- @since 3.0.16.0
221−setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
222−setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l }
223−
224−-- | Do not limit the maximum size of the sum of all parameters.
225−--
226−-- @since 3.0.16.0
227−clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
228−clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing }
229−
230−-- | Set the maximum header lines per mime/multipart entry.
231−--
232−-- @since 3.0.16.0
233−setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
234−setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l }
235−
236−-- | Do not limit the maximum header lines per mime/multipart entry.
237−--
238−-- @since 3.0.16.0
239−clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions
240−clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing }
241−
242−-- | Set the maximum header line length per mime/multipart entry.
243−--
244−-- @since 3.0.16.0
245−setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
246−setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l }
247−
248−-- | Do not limit the maximum header lines per mime/multipart entry.
249−--
250−-- @since 3.0.16.0
251−clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
252−clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }
253−
254−-- | A reasonable default set of parsing options.
255−-- Maximum key/filename length: 32 bytes;
256−-- maximum files: 10; filesize unlimited; maximum
257−-- size for parameters: 64kbytes; maximum number of header
258−-- lines: 32 bytes (applies only to headers of a mime/multipart message);
259−-- maximum header line length: Apache's default for that is 8190 bytes
260−-- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline)
261−-- so we're using that here as well.
262−--
263−-- @since 3.0.16.0
264−defaultParseRequestBodyOptions :: ParseRequestBodyOptions
265−defaultParseRequestBodyOptions = ParseRequestBodyOptions
266− { prboKeyLength=Just 32
267− , prboMaxNumFiles=Just 10
268− , prboMaxFileSize=Nothing
269− , prboMaxFilesSize=Nothing
270− , prboMaxParmsSize=Just 65336
271− , prboMaxHeaderLines=Just 32
272− , prboMaxHeaderLineLength=Just 8190 }
273−
274−-- | Do not impose any memory limits.
275−--
276−-- @since 3.0.21.0
277−noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
278−noLimitParseRequestBodyOptions = ParseRequestBodyOptions
279− { prboKeyLength=Nothing
280− , prboMaxNumFiles=Nothing
281− , prboMaxFileSize=Nothing
282− , prboMaxFilesSize=Nothing
283− , prboMaxParmsSize=Nothing
284− , prboMaxHeaderLines=Nothing
285− , prboMaxHeaderLineLength=Nothing }
286111
287112-- | Information on an uploaded file.
288113data FileInfo c = FileInfo
@@ -298,26 +123,17 @@ type Param = (S.ByteString, S.ByteString)
298123-- | Post parameter name and associated file information.
299124type File y = (S.ByteString, FileInfo y)
300125
301−-- | A file uploading backend. Takes the parameter name, file name, and a
302−-- stream of data.
126+-- | A file uploading backend. Takes the parameter name, file name, and content
127+-- type, and returns a `Sink` for storing the contents.
303128type BackEnd a = S.ByteString -- ^ parameter name
304129 -> FileInfo ()
305− -> IO S.ByteString
306− -> IO a
307−
308−-- | The mimetype of the http body.
309−-- Depending on whether just parameters or parameters and files
310−-- are passed, one or the other mimetype should be used.
311−data RequestBodyType
312− = -- | application/x-www-form-urlencoded (parameters only)
313− UrlEncoded
314− | -- | multipart/form-data (parameters and files)
315− Multipart S.ByteString
316−
317−-- | Get the mimetype of the body of an http request.
130+ -> Sink S.ByteString (ResourceT IO) a
131+
132+data RequestBodyType = UrlEncoded | Multipart S.ByteString
133+
318134getRequestBodyType :: Request -> Maybe RequestBodyType
319135getRequestBodyType req = do
320− ctype' <- lookup hContentType $ requestHeaders req
136+ ctype' <- lookup "Content-Type" $ requestHeaders req
321137 let (ctype, attrs) = parseContentType ctype'
322138 case ctype of
323139 "application/x-www-form-urlencoded" -> return UrlEncoded
@@ -327,7 +143,7 @@ getRequestBodyType req = do
327143-- | Parse a content type value, turning a single @ByteString@ into the actual
328144-- content type and a list of pairs of attributes.
329145--
330−-- @since 1.3.2
146+-- Since 1.3.2
331147parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
332148parseContentType a = do
333149 let (ctype, b) = S.break (== semicolon) a
@@ -337,9 +153,6 @@ parseContentType a = do
337153 semicolon = 59
338154 equals = 61
339155 space = 32
340− dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote
341− then S.tail $ S.init s
342− else s
343156 goAttrs front bs
344157 | S.null bs = front []
345158 | otherwise =
@@ -348,172 +161,81 @@ parseContentType a = do
348161 goAttr bs =
349162 let (k, v') = S.break (== equals) bs
350163 v = S.drop 1 v'
351− in (strip k, dq $ strip v)
164+ in (strip k, strip v)
352165 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
353166
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.
360167parseRequestBody :: BackEnd y
361168 -> Request
362− -> IO ([Param], [File y])
363−parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions
364−
365−-- | Parse the body of an HTTP request, limit resource usage.
366−-- The HTTP body can contain both parameters and files.
367−-- This function will return a list of key,value pairs
368−-- for all parameters, and a list of key,a pairs
369−-- for filenames. The a depends on the used backend that
370−-- is responsible for storing the received files.
371−parseRequestBodyEx :: ParseRequestBodyOptions
372− -> BackEnd y
373− -> Request
374− -> IO ([Param], [File y])
375−parseRequestBodyEx o s r =
169+ -> ResourceT IO ([Param], [File y])
170+parseRequestBody s r =
376171 case getRequestBodyType r of
377172 Nothing -> return ([], [])
378− Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
173+ Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume
379174
380175sinkRequestBody :: BackEnd y
381176 -> RequestBodyType
382− -> IO S.ByteString
383− -> IO ([Param], [File y])
384−sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
177+ -> Sink S.ByteString (ResourceT IO) ([Param], [File y])
178+sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume
385179
386−-- |
387−--
388−-- @since 3.0.16.0
389−sinkRequestBodyEx :: ParseRequestBodyOptions
390− -> BackEnd y
391− -> RequestBodyType
392− -> IO S.ByteString
393− -> IO ([Param], [File y])
394−sinkRequestBodyEx o s r body = do
395− ref <- newIORef ([], [])
396− let add x = atomicModifyIORef ref $ \(y, z) ->
397− case x of
398− Left y' -> ((y':y, z), ())
399− Right z' -> ((y, z':z), ())
400− conduitRequestBodyEx o s r body add
401− (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref
402−
403−conduitRequestBodyEx :: ParseRequestBodyOptions
404− -> BackEnd y
405− -> RequestBodyType
406− -> IO S.ByteString
407− -> (Either Param (File y) -> IO ())
408− -> IO ()
409−conduitRequestBodyEx o _ UrlEncoded rbody add = do
180+conduitRequestBody :: BackEnd y
181+ -> RequestBodyType
182+ -> Conduit S.ByteString (ResourceT IO) (Either Param (File y))
183+conduitRequestBody _ UrlEncoded = do
410184 -- NOTE: in general, url-encoded data will be in a single chunk.
411185 -- Therefore, I'm optimizing for the usual case by sticking with
412186 -- strict byte strings here.
413− let loop size front = do
414− bs <- rbody
415− if S.null bs
416− then return $ S.concat $ front []
417− else do
418− let newsize = size + S.length bs
419− case prboMaxParmsSize o of
420− Just maxSize -> when (newsize > maxSize) $
421− error "Maximum size of parameters exceeded"
422− Nothing -> return ()
423− loop newsize $ front . (bs:)
424− bs <- loop 0 id
425− mapM_ (add . Left) $ H.parseSimpleQuery bs
426−conduitRequestBodyEx o backend (Multipart bound) rbody add =
427− parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add
428−
429−
430−-- | Take one header or subheader line.
431−-- Since: 3.0.26
432−-- Throw 431 if headers too large.
433−takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
434−takeLine maxlen src =
435− go ""
187+ bs <- CL.consume
188+ mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs
189+conduitRequestBody backend (Multipart bound) =
190+ parsePieces backend $ S8.pack "--" `S.append` bound
191+
192+#if MIN_VERSION_conduit(1, 0, 0)
193+takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString)
194+#else
195+takeLine :: Monad m => Pipe S.ByteString S.ByteString o u m (Maybe S.ByteString)
196+#endif
197+takeLine =
198+ go id
436199 where
437− go front = do
438− bs <- readSource src
439− case maxlen of
440− Just maxlen' -> when (S.length front > maxlen') $
441− E.throwIO $ ConnectionError (UnknownErrorCode 431)
442− "Request Header Fields Too Large"
443− Nothing -> return ()
444− if S.null bs
445− then close front
446− else push front bs
447−
448− close front = leftover src front >> return Nothing
200+ go front = await >>= maybe (close front) (push front)
201+
202+ close front = leftover (front S.empty) >> return Nothing
449203 push front bs = do
450− let (x, y) = S.break (== 10) bs -- LF
204+ let (x, y) = S.break (== 10) $ front bs -- LF
451205 in if S.null y
452− then go $ front `S.append` x
206+ then go $ S.append x
453207 else do
454− when (S.length y > 1) $ leftover src $ S.drop 1 y
455− let res = front `S.append` x
456− case maxlen of
457− Just maxlen' -> when (S.length res > maxlen') $
458− E.throwIO $ ConnectionError (UnknownErrorCode 431)
459− "Request Header Fields Too Large"
460− Nothing -> return ()
461− return $ Just $ killCR $ res
462−
463−takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
464−takeLines' lineLength maxLines source =
465− reverse <$> takeLines'' [] lineLength maxLines source
466−
467−takeLines''
468− :: [S.ByteString]
469− -> Maybe Int
470− -> Maybe Int
471− -> Source
472− -> IO [S.ByteString]
473−takeLines'' lines lineLength maxLines src = do
474− case maxLines of
475− Just maxLines' ->
476− when (length lines > maxLines') $
477− error "Too many lines in mime/multipart header"
478− Nothing -> return ()
479− res <- takeLine lineLength src
208+ when (S.length y > 1) $ leftover $ S.drop 1 y
209+ return $ Just $ killCR x
210+
211+#if MIN_VERSION_conduit(1, 0, 0)
212+takeLines :: Consumer S.ByteString (ResourceT IO) [S.ByteString]
213+#else
214+takeLines :: Pipe S.ByteString S.ByteString o u (ResourceT IO) [S.ByteString]
215+#endif
216+takeLines = do
217+ res <- takeLine
480218 case res of
481− Nothing -> return lines
219+ Nothing -> return []
482220 Just l
483− | S.null l -> return lines
484− | otherwise -> takeLines'' (l:lines) lineLength maxLines src
485−
486−data Source = Source (IO S.ByteString) (IORef S.ByteString)
487−
488−mkSource :: IO S.ByteString -> IO Source
489−mkSource f = do
490− ref <- newIORef S.empty
491− return $ Source f ref
492−
493−readSource :: Source -> IO S.ByteString
494−readSource (Source f ref) = do
495− bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs)
496− if S.null bs
497− then f
498− else return bs
499−
500−leftover :: Source -> S.ByteString -> IO ()
501−leftover (Source _ ref) bs = writeIORef ref bs
502−
503−parsePiecesEx :: ParseRequestBodyOptions
504− -> BackEnd y
505− -> S.ByteString
506− -> IO S.ByteString
507− -> (Either Param (File y) -> IO ())
508− -> IO ()
509−parsePiecesEx o sink bound rbody add =
510− mkSource rbody >>= loop 0 0 0 0
221+ | S.null l -> return []
222+ | otherwise -> do
223+ ls <- takeLines
224+ return $ l : ls
225+
226+parsePieces :: BackEnd y
227+ -> S.ByteString
228+#if MIN_VERSION_conduit(1, 0, 0)
229+ -> ConduitM S.ByteString (Either Param (File y)) (ResourceT IO) ()
230+#else
231+ -> Pipe S.ByteString S.ByteString (Either Param (File y)) u (ResourceT IO) ()
232+#endif
233+parsePieces sink bound =
234+ loop
511235 where
512− loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
513− loop numParms numFiles parmSize filesSize src = do
514− _boundLine <- takeLine (prboMaxHeaderLineLength o) src
515− res' <- takeLines' (prboMaxHeaderLineLength o)
516− (prboMaxHeaderLines o) src
236+ loop = do
237+ _boundLine <- takeLine
238+ res' <- takeLines
517239 unless (null res') $ do
518240 let ls' = map parsePair res'
519241 let x = do
@@ -524,57 +246,31 @@ parsePiecesEx o sink bound rbody add =
524246 return (ct, name, lookup "filename" attrs)
525247 case x of
526248 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 ()
536249 let ct = fromMaybe "application/octet-stream" mct
537250 fi0 = FileInfo filename ct ()
538− fs = catMaybes [ prboMaxFileSize o
539− , subtract filesSize <$> prboMaxFilesSize o ]
540− mfs = if fs == [] then Nothing else Just $ minimum fs
541− ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
542− let newFilesSize = filesSize + fileSize
543− add $ Right (name, fi0 { fileContent = y })
544− when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
251+ (wasFound, y) <- sinkTillBound' bound name fi0 sink
252+ yield $ Right (name, fi0 { fileContent = y })
253+ when wasFound loop
545254 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 ()
551255 let seed = id
552256 let iter front bs = return $ front . (:) bs
553− ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src
554− (fromIntegral <$> prboMaxParmsSize o)
257+ (wasFound, front) <- sinkTillBound bound iter seed
555258 let bs = S.concat $ front []
556259 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 ()
562− add $ Left x'
563− when wasFound $ loop (numParms + 1) numFiles
564− newParmSize filesSize src
260+ yield $ Left x'
261+ when wasFound loop
565262 _ -> do
566263 -- ignore this part
567264 let seed = ()
568265 iter () _ = return ()
569− ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
570− when wasFound $ loop numParms numFiles parmSize filesSize src
266+ (wasFound, ()) <- sinkTillBound bound iter seed
267+ when wasFound loop
571268 where
572− contDisp = mk $ S8.pack "Content-Disposition"
573− contType = mk $ S8.pack "Content-Type"
269+ contDisp = S8.pack "Content-Disposition"
270+ contType = S8.pack "Content-Type"
574271 parsePair s =
575272 let (x, y) = breakDiscard 58 s -- colon
576− in (mk $ x, S.dropWhile (== 32) y) -- space
577−
273+ in (x, S.dropWhile (== 32) y) -- space
578274
579275data Bound = FoundBound S.ByteString S.ByteString
580276 | NoBound
@@ -582,7 +278,7 @@ data Bound = FoundBound S.ByteString S.ByteString
582278 deriving (Eq, Show)
583279
584280findBound :: S.ByteString -> S.ByteString -> Bound
585−findBound b bs = handleBreak $ S.breakSubstring b bs
281+findBound b bs = handleBreak $ Search.breakOn b bs
586282 where
587283 handleBreak (h, t)
588284 | S.null t = go [lowBound..S.length bs - 1]
@@ -608,90 +304,90 @@ sinkTillBound' :: S.ByteString
608304 -> S.ByteString
609305 -> FileInfo ()
610306 -> BackEnd y
611− -> Source
612− -> Maybe Int64
613− -> IO ((Bool, Int64), y)
614−sinkTillBound' bound name fi sink src max' = do
615− (next, final) <- wrapTillBound bound src max'
616− y <- sink name fi next
617− b <- final
618− return (b, y)
619−
620−data WTB = WTBWorking (S.ByteString -> S.ByteString)
621− | WTBDone Bool
622−wrapTillBound :: S.ByteString -- ^ bound
623− -> Source
624− -> Maybe Int64
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)
307+#if MIN_VERSION_conduit(1, 0, 0)
308+ -> ConduitM S.ByteString o (ResourceT IO) (Bool, y)
309+#else
310+ -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, y)
311+#endif
312+sinkTillBound' bound name fi sink =
313+#if MIN_VERSION_conduit(1, 0, 0)
314+ ConduitM $ anyOutput $
315+#endif
316+ conduitTillBound bound >+> withUpstream (fix $ sink name fi)
630317 where
631− final ref sref = do
632− x <- readIORef ref
633− case x of
634− WTBWorking _ -> error "wrapTillBound did not finish"
635− WTBDone y -> do
636− siz <- readIORef sref
637− return (y, siz)
638−
639− go ref sref = do
640− state <- readIORef ref
641− case state of
642− WTBDone _ -> return S.empty
643− WTBWorking front -> do
644− bs <- readSource src
645− cur <- atomicModifyIORef' sref $ \ cur ->
646− let new = cur + fromIntegral (S.length bs) in (new, new)
647− case max' of
648− Just max'' | cur > max'' ->
649− E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"
650− _ -> return ()
651− if S.null bs
652− then do
653− writeIORef ref $ WTBDone False
654− return $ front bs
655− else push $ front bs
656− where
657− push bs = do
658− case findBound bound bs of
659− FoundBound before after -> do
660− let before' = killCRLF before
661− leftover src after
662− writeIORef ref $ WTBDone True
663− return before'
664− NoBound -> do
665− -- don't emit newlines, in case it's part of a bound
666− let (toEmit, front') =
667− if not (S8.null bs) && S8.last bs `elem` ['\r','\n']
668− then let (x, y) = S.splitAt (S.length bs - 2) bs
669− in (x, S.append y)
670− else (bs, id)
671− writeIORef ref $ WTBWorking front'
672− if S.null toEmit
673− then go ref sref
674− else return toEmit
675− PartialBound -> do
676− writeIORef ref $ WTBWorking $ S.append bs
677− go ref sref
318+#if MIN_VERSION_conduit(1, 0, 0)
319+ fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool (ResourceT IO) y
320+ fix (ConduitM p) = ignoreTerm >+> injectLeftovers p
321+ ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)
322+ await' = NeedInput (return . Just) (const $ return Nothing)
323+ yield' = HaveOutput (return ()) (return ())
324+
325+ anyOutput p = p >+> dropInput
326+ dropInput = NeedInput (const dropInput) return
327+#else
328+ fix = sinkToPipe
329+#endif
330+
331+conduitTillBound :: Monad m
332+ => S.ByteString -- bound
333+#if MIN_VERSION_conduit(1, 0, 0)
334+ -> Pipe S.ByteString S.ByteString S.ByteString () m Bool
335+#else
336+ -> Pipe S.ByteString S.ByteString S.ByteString u m Bool
337+#endif
338+conduitTillBound bound =
339+#if MIN_VERSION_conduit(1, 0, 0)
340+ unConduitM $
341+#endif
342+ go id
343+ where
344+ go front = await >>= maybe (close front) (push front)
345+ close front = do
346+ let bs = front S.empty
347+ unless (S.null bs) $ yield bs
348+ return False
349+ push front bs' = do
350+ let bs = front bs'
351+ case findBound bound bs of
352+ FoundBound before after -> do
353+ let before' = killCRLF before
354+ yield before'
355+ leftover after
356+ return True
357+ NoBound -> do
358+ -- don't emit newlines, in case it's part of a bound
359+ let (toEmit, front') =
360+ if not (S8.null bs) && S8.last bs `elem` "\r\n"
361+ then let (x, y) = S.splitAt (S.length bs - 2) bs
362+ in (x, S.append y)
363+ else (bs, id)
364+ yield toEmit
365+ go front'
366+ PartialBound -> go $ S.append bs
678367
679368sinkTillBound :: S.ByteString
680369 -> (x -> S.ByteString -> IO x)
681370 -> x
682− -> Source
683− -> Maybe Int64
684− -> IO ((Bool, Int64), x)
685−sinkTillBound bound iter seed0 src max' = do
686− (next, final) <- wrapTillBound bound src max'
687− let loop seed = do
688− bs <- next
689− if S.null bs
690− then return seed
691− else iter seed bs >>= loop
692− seed <- loop seed0
693− b <- final
694− return (b, seed)
371+#if MIN_VERSION_conduit(1, 0, 0)
372+ -> Consumer S.ByteString (ResourceT IO) (Bool, x)
373+#else
374+ -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, x)
375+#endif
376+sinkTillBound bound iter seed0 =
377+#if MIN_VERSION_conduit(1, 0, 0)
378+ ConduitM $
379+#endif
380+ (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0))
381+ where
382+ iter' a b = liftIO $ iter a b
383+#if MIN_VERSION_conduit(1, 0, 0)
384+ ij (ConduitM p) = ignoreTerm >+> injectLeftovers p
385+ ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)
386+ await' = NeedInput (return . Just) (const $ return Nothing)
387+ yield' = HaveOutput (return ()) (return ())
388+#else
389+ ij = id
390+#endif
695391
696392parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
697393parseAttrs = map go . S.split 59 -- semicolon