Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 895 lines (726 sloc) 34.111 kb
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE ExistentialQuantification #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6
5b05b45 @mightybyte Style cleanup
mightybyte authored
7 ------------------------------------------------------------------------------
6d19baf @gregorycollins Twiddle file-upload docs
gregorycollins authored
8 -- | This module contains primitives and helper functions for handling
9 -- requests with @Content-type: multipart/form-data@, i.e. HTML forms and file
10 -- uploads.
11 --
12 -- Typically most users will want to use 'handleFileUploads', which writes
13 -- uploaded files to a temporary directory before sending them on to a handler
14 -- specified by the user.
15 --
16 -- Users who wish to handle their file uploads differently can use the
17 -- lower-level streaming 'Iteratee' interface called 'handleMultipart'. That
18 -- function takes uploaded files and streams them to an 'Iteratee' consumer of
19 -- the user's choosing.
20 --
21 -- Using these functions requires making \"policy\" decisions which Snap can't
22 -- really make for users, such as \"what's the largest PDF file a user is
23 -- allowed to upload?\" and \"should we read form inputs into the parameters
24 -- mapping?\". Policy is specified on a \"global\" basis (using
25 -- 'UploadPolicy'), and on a per-file basis (using 'PartUploadPolicy', which
5b05b45 @mightybyte Style cleanup
mightybyte authored
26 -- allows you to reject or limit the size of certain uploaded
27 -- @Content-type@s).
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
28 module Snap.Util.FileUploads
6d19baf @gregorycollins Twiddle file-upload docs
gregorycollins authored
29 ( -- * Functions
30 handleFileUploads
31 , handleMultipart
32
33 -- * Uploaded parts
34 , PartInfo(..)
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
35
36 -- ** Policy
37 -- *** General upload policy
38 , UploadPolicy
39 , defaultUploadPolicy
40 , doProcessFormInputs
41 , setProcessFormInputs
42 , getMaximumFormInputSize
43 , setMaximumFormInputSize
44 , getMinimumUploadRate
45 , setMinimumUploadRate
46 , getMinimumUploadSeconds
47 , setMinimumUploadSeconds
48 , getUploadTimeout
49 , setUploadTimeout
50
51 -- *** Per-file upload policy
52 , PartUploadPolicy
53 , disallow
54 , allowWithMaximumSize
55
56 -- * Exceptions
57 , FileUploadException
58 , fileUploadExceptionReason
59 , BadPartException
60 , badPartExceptionReason
61 , PolicyViolationException
62 , policyViolationExceptionReason
63 ) where
64
65 ------------------------------------------------------------------------------
66 import Control.Arrow
67 import Control.Applicative
68 import Control.Exception (SomeException(..))
69 import Control.Monad
70 import Control.Monad.CatchIO
71 import Control.Monad.Trans
72 import qualified Data.Attoparsec.Char8 as Atto
73 import Data.Attoparsec.Char8 hiding (many, Result(..))
74 import Data.Attoparsec.Enumerator
75 import qualified Data.ByteString.Char8 as S
76 import Data.ByteString.Char8 (ByteString)
77 import Data.ByteString.Internal (c2w)
af0a9be @basvandijk Use case-insensitive instead of CIByteString
basvandijk authored
78 import qualified Data.CaseInsensitive as CI
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
79 import qualified Data.DList as D
80 import Data.Enumerator.Binary (iterHandle)
81 import Data.IORef
82 import Data.Int
83 import Data.List hiding (takeWhile)
84 import qualified Data.Map as Map
85 import Data.Maybe
86 import qualified Data.Text as T
87 import Data.Text (Text)
88 import qualified Data.Text.Encoding as TE
89 import Data.Typeable
90 import Prelude hiding (catch, getLine, takeWhile)
91 import System.Directory
92 import System.IO hiding (isEOF)
93 ------------------------------------------------------------------------------
94 import Snap.Iteratee hiding (map)
95 import qualified Snap.Iteratee as I
96 import Snap.Internal.Debug
97 import Snap.Internal.Iteratee.Debug
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horsp…
gregorycollins authored
98 import Snap.Internal.Iteratee.BoyerMooreHorspool
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
99 import Snap.Internal.Parsing
100 import Snap.Types
101
102
103 ------------------------------------------------------------------------------
5b05b45 @mightybyte Style cleanup
mightybyte authored
104 -- | Reads uploaded files into a temporary directory and calls a user handler
105 -- to process them.
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
106 --
5b05b45 @mightybyte Style cleanup
mightybyte authored
107 -- Given a temporary directory, global and file-specific upload policies, and
108 -- a user handler, this function consumes a request body uploaded with
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
109 -- @Content-type: multipart/form-data@. Each file is read into the temporary
110 -- directory, and then a list of the uploaded files is passed to the user
111 -- handler. After the user handler runs (but before the 'Response' body
5b05b45 @mightybyte Style cleanup
mightybyte authored
112 -- 'Enumerator' is streamed to the client), the files are deleted from disk;
113 -- so if you want to retain or use the uploaded files in the generated
114 -- response, you would need to move or otherwise process them.
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
115 --
116 -- The argument passed to the user handler is a list of:
117 --
118 -- > (PartInfo, Either PolicyViolationException FilePath)
119 --
5b05b45 @mightybyte Style cleanup
mightybyte authored
120 -- The first half of this tuple is a 'PartInfo', which contains the
121 -- information the client browser sent about the given upload part (like
122 -- filename, content-type, etc). The second half of this tuple is an 'Either'
123 -- stipulating that either:
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
124 --
125 -- 1. the file was rejected on a policy basis because of the provided
126 -- 'PartUploadPolicy' handler
127 --
128 -- 2. the file was accepted and exists at the given path.
129 --
130 -- If the request's @Content-type@ was not \"@multipart/formdata@\", this
131 -- function skips processing using 'pass'.
132 --
133 -- If the client's upload rate passes below the configured minimum (see
134 -- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function throws
135 -- a 'RateTooSlowException'. This setting is there to protect the server
136 -- against slowloris-style denial of service attacks.
137 --
138 -- If the given 'UploadPolicy' stipulates that you wish form inputs to be
5b05b45 @mightybyte Style cleanup
mightybyte authored
139 -- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and
140 -- a form input exceeds the maximum allowable size, this function will throw a
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
141 -- 'PolicyViolationException'.
142 --
143 -- If an uploaded part contains MIME headers longer than a fixed internal
144 -- threshold (currently 32KB), this function will throw a 'BadPartException'.
145
146 handleFileUploads ::
147 (MonadSnap m) =>
148 FilePath -- ^ temporary directory
149 -> UploadPolicy -- ^ general upload policy
150 -> (PartInfo -> PartUploadPolicy) -- ^ per-part upload policy
151 -> ([(PartInfo, Either PolicyViolationException FilePath)] -> m a)
152 -- ^ user handler (see function
153 -- description)
154 -> m a
155 handleFileUploads tmpdir uploadPolicy partPolicy handler = do
156 uploadedFiles <- newUploadedFiles
157
158 (do
159 xs <- handleMultipart uploadPolicy (iter uploadedFiles)
160 handler xs
161 ) `finally` (cleanupUploadedFiles uploadedFiles)
162
163 where
164 iter uploadedFiles partInfo = maybe disallowed takeIt mbFs
165 where
166 ctText = partContentType partInfo
167 fnText = fromMaybe "" $ partFileName partInfo
168
169 ct = TE.decodeUtf8 ctText
170 fn = TE.decodeUtf8 fnText
171
172 (PartUploadPolicy mbFs) = partPolicy partInfo
173
174 retVal (_,x) = (partInfo, Right x)
175
176 takeIt maxSize = do
177 let it = fmap retVal $
178 joinI' $
179 takeNoMoreThan maxSize $$
180 fileReader uploadedFiles tmpdir partInfo
181
182 it `catches` [ Handler $ \(_ :: TooManyBytesReadException) ->
183 (skipToEof >> tooMany maxSize)
184 , Handler $ \(e :: SomeException) -> throw e
185 ]
186
187 tooMany maxSize =
188 return ( partInfo
189 , Left $ PolicyViolationException
190 $ T.concat [ "File \""
191 , fn
192 , "\" exceeded maximum allowable size "
193 , T.pack $ show maxSize ] )
194
195 disallowed =
196 return ( partInfo
197 , Left $ PolicyViolationException
198 $ T.concat [ "Policy disallowed upload of file \""
199 , fn
200 , "\" with content-type \""
201 , ct
202 , "\"" ] )
203
204
205 ------------------------------------------------------------------------------
206 -- | Given an upload policy and a function to consume uploaded \"parts\",
207 -- consume a request body uploaded with @Content-type: multipart/form-data@.
208 -- Normally most users will want to use 'handleFileUploads' (which writes
209 -- uploaded files to a temporary directory and passes their names to a given
210 -- handler) rather than this function; the lower-level 'handleMultipart'
211 -- function should be used if you want to stream uploaded files to your own
212 -- iteratee function.
213 --
214 -- If the request's @Content-type@ was not \"@multipart/formdata@\", this
215 -- function skips processing using 'pass'.
216 --
217 -- If the client's upload rate passes below the configured minimum (see
218 -- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function throws
219 -- a 'RateTooSlowException'. This setting is there to protect the server
220 -- against slowloris-style denial of service attacks.
221 --
222 -- If the given 'UploadPolicy' stipulates that you wish form inputs to be
5b05b45 @mightybyte Style cleanup
mightybyte authored
223 -- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and
224 -- a form input exceeds the maximum allowable size, this function will throw a
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
225 -- 'PolicyViolationException'.
226 --
227 -- If an uploaded part contains MIME headers longer than a fixed internal
228 -- threshold (currently 32KB), this function will throw a 'BadPartException'.
229 --
230 handleMultipart ::
231 (MonadSnap m) =>
232 UploadPolicy -- ^ global upload policy
233 -> (PartInfo -> Iteratee ByteString IO a) -- ^ part processor
234 -> m [a]
235 handleMultipart uploadPolicy origPartHandler = do
236 hdrs <- liftM headers getRequest
237 let (ct, mbBoundary) = getContentType hdrs
238
239 tickleTimeout <- getTimeoutAction
240 let bumpTimeout = tickleTimeout $ uploadTimeout uploadPolicy
241
242 let partHandler = if doProcessFormInputs uploadPolicy
243 then captureVariableOrReadFile
244 (getMaximumFormInputSize uploadPolicy)
245 origPartHandler
246 else (\p -> fmap File (origPartHandler p))
247
248 -- not well-formed multipart? bomb out.
249 when (ct /= "multipart/form-data") $ do
250 debug $ "handleMultipart called with content-type=" ++ S.unpack ct
251 ++ ", passing"
252 pass
253
254 when (isNothing mbBoundary) $
255 throw $ BadPartException $
256 "got multipart/form-data without boundary"
257
258 let boundary = fromJust mbBoundary
259 captures <- runRequestBody (iter bumpTimeout boundary partHandler `catch`
260 errHandler)
261
262 procCaptures [] captures
263
264 where
265 iter bump boundary ph = killIfTooSlow
266 bump
267 (minimumUploadRate uploadPolicy)
268 (minimumUploadSeconds uploadPolicy)
269 (internalHandleMultipart boundary ph)
270
271 errHandler (e :: SomeException) = skipToEof >> (lift $ throw e)
272
273 ins k v = Map.insertWith' (\a b -> Prelude.head a : b) k [v]
274
275 maxFormVars = maximumNumberOfFormInputs uploadPolicy
276
277 procCaptures l [] = return $ reverse l
278 procCaptures l ((File x):xs) = procCaptures (x:l) xs
279 procCaptures l ((Capture k v):xs) = do
280 rq <- getRequest
281 let n = Map.size $ rqParams rq
282 when (n >= maxFormVars) $
283 throw $ PolicyViolationException $
284 T.concat [ "number of form inputs exceeded maximum of "
285 , T.pack $ show maxFormVars ]
286 modifyRequest $ rqModifyParams (ins k v)
287 procCaptures l xs
288
289
290 ------------------------------------------------------------------------------
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
291 -- | 'PartInfo' contains information about a \"part\" in a request uploaded
292 -- with @Content-type: multipart/form-data@.
293 data PartInfo =
294 PartInfo { partFieldName :: !ByteString
295 , partFileName :: !(Maybe ByteString)
296 , partContentType :: !ByteString
297 }
298 deriving (Show)
299
300
301 ------------------------------------------------------------------------------
a0b5853 @gregorycollins Document file upload exception hierarchy
gregorycollins authored
302 -- | All of the exceptions defined in this package inherit from
303 -- 'FileUploadException', so if you write
304 --
305 -- > foo `catch` \(e :: FileUploadException) -> ...
306 --
307 -- you can catch a 'BadPartException', a 'PolicyViolationException', etc.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
308 data FileUploadException =
309 GenericFileUploadException {
310 _genericFileUploadExceptionReason :: Text
311 }
312 | forall e . (Exception e, Show e) =>
313 WrappedFileUploadException {
314 _wrappedFileUploadException :: e
315 , _wrappedFileUploadExceptionReason :: Text
316 }
317 deriving (Typeable)
318
319
320 ------------------------------------------------------------------------------
321 instance Show FileUploadException where
322 show (GenericFileUploadException r) = "File upload exception: " ++
323 T.unpack r
324 show (WrappedFileUploadException e _) = show e
325
326
327 ------------------------------------------------------------------------------
328 instance Exception FileUploadException
329
330
331 ------------------------------------------------------------------------------
332 fileUploadExceptionReason :: FileUploadException -> Text
333 fileUploadExceptionReason (GenericFileUploadException r) = r
334 fileUploadExceptionReason (WrappedFileUploadException _ r) = r
335
336
337 ------------------------------------------------------------------------------
338 uploadExceptionToException :: Exception e => e -> Text -> SomeException
5b05b45 @mightybyte Style cleanup
mightybyte authored
339 uploadExceptionToException e r =
340 SomeException $ WrappedFileUploadException e r
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
341
342
343 ------------------------------------------------------------------------------
344 uploadExceptionFromException :: Exception e => SomeException -> Maybe e
345 uploadExceptionFromException x = do
346 WrappedFileUploadException e _ <- fromException x
347 cast e
348
349
350 ------------------------------------------------------------------------------
351 data BadPartException = BadPartException { badPartExceptionReason :: Text }
352 deriving (Typeable)
353
354 instance Exception BadPartException where
355 toException e@(BadPartException r) = uploadExceptionToException e r
356 fromException = uploadExceptionFromException
357
358 instance Show BadPartException where
359 show (BadPartException s) = "Bad part: " ++ T.unpack s
360
361
362 ------------------------------------------------------------------------------
363 data PolicyViolationException = PolicyViolationException {
364 policyViolationExceptionReason :: Text
365 } deriving (Typeable)
366
367 instance Exception PolicyViolationException where
5b05b45 @mightybyte Style cleanup
mightybyte authored
368 toException e@(PolicyViolationException r) =
369 uploadExceptionToException e r
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
370 fromException = uploadExceptionFromException
371
372 instance Show PolicyViolationException where
373 show (PolicyViolationException s) = "File upload policy violation: "
374 ++ T.unpack s
375
376
377 ------------------------------------------------------------------------------
378 -- | 'UploadPolicy' controls overall policy decisions relating to
379 -- @multipart/form-data@ uploads, specifically:
380 --
381 -- * whether to treat parts without filenames as form input (reading them into
382 -- the 'rqParams' map)
383 --
384 -- * because form input is read into memory, the maximum size of a form input
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
385 -- read in this manner, and the maximum number of form inputs
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
386 --
387 -- * the minimum upload rate a client must maintain before we kill the
388 -- connection; if very low-bitrate uploads were allowed then a Snap server
389 -- would be vulnerable to a trivial denial-of-service using a
390 -- \"slowloris\"-type attack
391 --
392 -- * the minimum number of seconds which must elapse before we start killing
393 -- uploads for having too low an upload rate.
394 --
395 -- * the amount of time we should wait before timing out the connection
396 -- whenever we receive input from the client.
397 data UploadPolicy = UploadPolicy {
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
398 processFormInputs :: Bool
399 , maximumFormInputSize :: Int
400 , maximumNumberOfFormInputs :: Int
401 , minimumUploadRate :: Double
402 , minimumUploadSeconds :: Int
403 , uploadTimeout :: Int
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
404 } deriving (Show, Eq)
405
406
407 ------------------------------------------------------------------------------
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
408 -- | A reasonable set of defaults for upload policy. The default policy is:
409 --
410 -- [@maximum form input size@] 128kB
411 --
412 -- [@maximum number of form inputs@] 10
413 --
414 -- [@minimum upload rate@] 1kB/s
415 --
416 -- [@seconds before rate limiting kicks in@] 10
417 --
418 -- [@inactivity timeout@] 20 seconds
419 --
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
420 defaultUploadPolicy :: UploadPolicy
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
421 defaultUploadPolicy = UploadPolicy True maxSize maxNum minRate minSeconds tout
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
422 where
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
423 maxSize = 2^(17::Int)
424 maxNum = 10
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
425 minRate = 1000
426 minSeconds = 10
427 tout = 20
428
429
430 ------------------------------------------------------------------------------
431 -- | Does this upload policy stipulate that we want to treat parts without
6d19baf @gregorycollins Twiddle file-upload docs
gregorycollins authored
432 -- filenames as form input?
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
433 doProcessFormInputs :: UploadPolicy -> Bool
434 doProcessFormInputs = processFormInputs
435
436
437 ------------------------------------------------------------------------------
438 -- | Set the upload policy for treating parts without filenames as form input.
439 setProcessFormInputs :: Bool -> UploadPolicy -> UploadPolicy
440 setProcessFormInputs b u = u { processFormInputs = b }
441
442
443 ------------------------------------------------------------------------------
444 -- | Get the maximum size of a form input which will be read into our
445 -- 'rqParams' map.
446 getMaximumFormInputSize :: UploadPolicy -> Int
447 getMaximumFormInputSize = maximumFormInputSize
448
449
450 ------------------------------------------------------------------------------
451 -- | Set the maximum size of a form input which will be read into our
452 -- 'rqParams' map.
453 setMaximumFormInputSize :: Int -> UploadPolicy -> UploadPolicy
454 setMaximumFormInputSize s u = u { maximumFormInputSize = s }
455
456
457 ------------------------------------------------------------------------------
458 -- | Get the minimum rate (in /bytes\/second/) a client must maintain before
459 -- we kill the connection.
460 getMinimumUploadRate :: UploadPolicy -> Double
461 getMinimumUploadRate = minimumUploadRate
462
463
464 ------------------------------------------------------------------------------
465 -- | Set the minimum rate (in /bytes\/second/) a client must maintain before
466 -- we kill the connection.
467 setMinimumUploadRate :: Double -> UploadPolicy -> UploadPolicy
468 setMinimumUploadRate s u = u { minimumUploadRate = s }
469
470
471 ------------------------------------------------------------------------------
472 -- | Get the amount of time which must elapse before we begin enforcing the
473 -- upload rate minimum
474 getMinimumUploadSeconds :: UploadPolicy -> Int
475 getMinimumUploadSeconds = minimumUploadSeconds
476
477
478 ------------------------------------------------------------------------------
479 -- | Set the amount of time which must elapse before we begin enforcing the
480 -- upload rate minimum
481 setMinimumUploadSeconds :: Int -> UploadPolicy -> UploadPolicy
482 setMinimumUploadSeconds s u = u { minimumUploadSeconds = s }
483
484
485 ------------------------------------------------------------------------------
486 -- | Get the \"upload timeout\". Whenever input is received from the client,
487 -- the connection timeout is set this many seconds in the future.
488 getUploadTimeout :: UploadPolicy -> Int
489 getUploadTimeout = uploadTimeout
490
491
492 ------------------------------------------------------------------------------
493 -- | Set the upload timeout.
494 setUploadTimeout :: Int -> UploadPolicy -> UploadPolicy
495 setUploadTimeout s u = u { uploadTimeout = s }
496
497
498 ------------------------------------------------------------------------------
499 -- | Upload policy can be set on an \"general\" basis (using 'UploadPolicy'),
500 -- but handlers can also make policy decisions on individual files\/parts
501 -- uploaded. For each part uploaded, handlers can decide:
502 --
503 -- * whether to allow the file upload at all
504 --
505 -- * the maximum size of uploaded files, if allowed
506 data PartUploadPolicy = PartUploadPolicy {
507 _maximumFileSize :: Maybe Int64
508 } deriving (Show, Eq)
509
510
511 ------------------------------------------------------------------------------
512 -- | Disallows the file to be uploaded.
513 disallow :: PartUploadPolicy
514 disallow = PartUploadPolicy Nothing
515
516
517 ------------------------------------------------------------------------------
518 -- | Allows the file to be uploaded, with maximum size /n/.
519 allowWithMaximumSize :: Int64 -> PartUploadPolicy
520 allowWithMaximumSize = PartUploadPolicy . Just
521
522
523 ------------------------------------------------------------------------------
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
524 -- private exports follow. FIXME: organize
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
525 ------------------------------------------------------------------------------
526
527 ------------------------------------------------------------------------------
528 captureVariableOrReadFile ::
529 Int -- ^ maximum size of form input
530 -> (PartInfo -> Iteratee ByteString IO a) -- ^ file reading code
531 -> (PartInfo -> Iteratee ByteString IO (Capture a))
532 captureVariableOrReadFile maxSize fileHandler partInfo =
533 case partFileName partInfo of
534 Nothing -> iter
535 _ -> liftM File $ fileHandler partInfo
536 where
537 iter = varIter `catchError` handler
538
539 fieldName = partFieldName partInfo
540
541 varIter = do
542 var <- liftM S.concat $
543 joinI' $
544 takeNoMoreThan (fromIntegral maxSize) $$ consume
545 return $ Capture fieldName var
546
547 handler e = do
548 let m = fromException e :: Maybe TooManyBytesReadException
549 case m of
550 Nothing -> throwError e
551 Just _ -> throwError $ PolicyViolationException $
552 T.concat [ "form input '"
553 , TE.decodeUtf8 fieldName
554 , "' exceeded maximum permissible size ("
555 , T.pack $ show maxSize
556 , " bytes)" ]
557
558
559 ------------------------------------------------------------------------------
560 data Capture a = Capture ByteString ByteString
561 | File a
562 deriving (Show)
563
564
565 ------------------------------------------------------------------------------
566 fileReader :: UploadedFiles
567 -> FilePath
568 -> PartInfo
569 -> Iteratee ByteString IO (PartInfo, FilePath)
570 fileReader uploadedFiles tmpdir partInfo = do
571 (fn, h) <- openFileForUpload uploadedFiles tmpdir
572 let i = iterateeDebugWrapper "fileReader" $ iter fn h
573 i `catch` \(e::SomeException) -> throwError e
574
575 where
576 iter fileName h = do
577 iterHandle h
578 debug "fileReader: closing active file"
579 closeActiveFile uploadedFiles
580 return (partInfo, fileName)
581
582
583 ------------------------------------------------------------------------------
584 internalHandleMultipart ::
585 ByteString -- ^ boundary value
586 -> (PartInfo -> Iteratee ByteString IO a) -- ^ part processor
587 -> Iteratee ByteString IO [a]
588 internalHandleMultipart boundary clientHandler = go `catch` errorHandler
589
590 where
591 --------------------------------------------------------------------------
592 errorHandler :: SomeException -> Iteratee ByteString IO a
593 errorHandler e = do
594 skipToEof
595 throwError e
596
597 --------------------------------------------------------------------------
598 go = do
599 -- swallow the first boundary
600 _ <- iterParser $ parseFirstBoundary boundary
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horsp…
gregorycollins authored
601 step <- iterateeDebugWrapper "boyer-moore" $
602 (bmhEnumeratee (fullBoundary boundary) $$ processParts iter)
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
603 liftM concat $ lift $ run_ $ returnI step
604
605 --------------------------------------------------------------------------
606 pBoundary b = Atto.try $ do
607 _ <- string "--"
608 string b
609
610 --------------------------------------------------------------------------
611 fullBoundary b = S.concat ["\r\n", "--", b]
612 pLine = takeWhile (not . isEndOfLine . c2w) <* eol
613 takeLine = pLine *> pure ()
614 parseFirstBoundary b = pBoundary b <|> (takeLine *> parseFirstBoundary b)
615
616
617 --------------------------------------------------------------------------
618 takeHeaders = hdrs `catchError` handler
619 where
620 hdrs = liftM toHeaders $
621 iterateeDebugWrapper "header parser" $
622 joinI' $
623 takeNoMoreThan mAX_HDRS_SIZE $$
624 iterParser pHeadersWithSeparator
625
626 handler e = do
627 let m = fromException e :: Maybe TooManyBytesReadException
628 case m of
629 Nothing -> throwError e
630 Just _ -> throwError $ BadPartException $
631 "headers exceeded maximum size"
632
633 --------------------------------------------------------------------------
634 iter = do
635 hdrs <- takeHeaders
636
637 -- are we using mixed?
638 let (contentType, mboundary) = getContentType hdrs
639
640 let (fieldName, fileName) = getFieldName hdrs
641
642 if contentType == "multipart/mixed"
643 then maybe (throwError $ BadPartException $
644 "got multipart/mixed without boundary")
645 (processMixed fieldName)
646 mboundary
647 else do
648 let info = PartInfo fieldName fileName contentType
649 liftM (:[]) $ clientHandler info
650
651
652 --------------------------------------------------------------------------
653 processMixed fieldName mixedBoundary = do
654 -- swallow the first boundary
655 _ <- iterParser $ parseFirstBoundary mixedBoundary
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horsp…
gregorycollins authored
656 step <- iterateeDebugWrapper "boyer-moore" $
657 (bmhEnumeratee (fullBoundary mixedBoundary) $$
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
658 processParts (mixedIter fieldName))
659 lift $ run_ $ returnI step
660
661
662 --------------------------------------------------------------------------
663 mixedIter fieldName = do
664 hdrs <- takeHeaders
665
666 let (contentType, _) = getContentType hdrs
667 let (_, fileName) = getFieldName hdrs
668
669 let info = PartInfo fieldName fileName contentType
670 clientHandler info
671
672
673 ------------------------------------------------------------------------------
674 getContentType :: Headers
675 -> (ByteString, Maybe ByteString)
676 getContentType hdrs = (contentType, boundary)
677 where
678 contentTypeValue = fromMaybe "text/plain" $
679 getHeader "content-type" hdrs
680
681 eCT = fullyParse contentTypeValue pContentTypeWithParameters
682 (contentType, params) = either (const ("text/plain", [])) id eCT
683
684 boundary = findParam "boundary" params
685
686
687 ------------------------------------------------------------------------------
688 getFieldName :: Headers -> (ByteString, Maybe ByteString)
689 getFieldName hdrs = (fieldName, fileName)
690 where
691 contentDispositionValue = fromMaybe "" $
692 getHeader "content-disposition" hdrs
693
694 eDisposition = fullyParse contentDispositionValue pValueWithParameters
695
696 (_, dispositionParameters) =
697 either (const ("", [])) id eDisposition
698
699 fieldName = fromMaybe "" $ findParam "name" dispositionParameters
700
701 fileName = findParam "filename" dispositionParameters
702
703
704 ------------------------------------------------------------------------------
705 findParam :: (Eq a) => a -> [(a, b)] -> Maybe b
706 findParam p = fmap snd . find ((== p) . fst)
707
708
709 ------------------------------------------------------------------------------
710 -- | Given a 'MatchInfo' stream which is partitioned by boundary values, read
711 -- up until the next boundary and send all of the chunks into the wrapped
712 -- iteratee
713 processPart :: (Monad m) => Enumeratee MatchInfo ByteString m a
7ae3621 @gregorycollins Kill one of the space leaks in file upload
gregorycollins authored
714 processPart st = {-# SCC "pPart/outer" #-}
715 case st of
716 (Continue k) -> go k
717 _ -> yield st (Chunks [])
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
718 where
719 go :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
720 -> Iteratee MatchInfo m (Step ByteString m a)
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horsp…
gregorycollins authored
721 go !k = {-# SCC "pPart/go" #-}
7ae3621 @gregorycollins Kill one of the space leaks in file upload
gregorycollins authored
722 I.head >>= maybe finish process
723 where
724 -- called when outer stream is EOF
725 finish = {-# SCC "pPart/finish" #-}
726 lift $ runIteratee $ k EOF
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
727
7ae3621 @gregorycollins Kill one of the space leaks in file upload
gregorycollins authored
728 -- no match ==> pass the stream chunk along
729 process (NoMatch !s) = {-# SCC "pPart/noMatch" #-} do
730 !step <- lift $ runIteratee $ k $ Chunks [s]
731 case step of
732 (Continue k') -> go k'
733 _ -> yield step (Chunks [])
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
734
7ae3621 @gregorycollins Kill one of the space leaks in file upload
gregorycollins authored
735 process (Match _) = {-# SCC "pPart/match" #-}
736 lift $ runIteratee $ k EOF
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
737
738
739 ------------------------------------------------------------------------------
740 -- | Assuming we've already identified the boundary value and run
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horsp…
gregorycollins authored
741 -- 'bmhEnumeratee' to split the input up into parts which match and parts
5b05b45 @mightybyte Style cleanup
mightybyte authored
742 -- which don't, run the given 'ByteString' iteratee over each part and grab a
743 -- list of the resulting values.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
744 processParts :: Iteratee ByteString IO a
745 -> Iteratee MatchInfo IO [a]
746 processParts partIter = iterateeDebugWrapper "processParts" $ go D.empty
747 where
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horsp…
gregorycollins authored
748 iter = {-# SCC "processParts/iter" #-} do
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
749 isLast <- bParser
750 if isLast
751 then return Nothing
752 else do
753 x <- partIter
754 skipToEof
755 return $ Just x
756
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horsp…
gregorycollins authored
757 go soFar = {-# SCC "processParts/go" #-} do
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
758 b <- isEOF
759
760 if b
761 then return $ D.toList soFar
762 else do
5b05b45 @mightybyte Style cleanup
mightybyte authored
763 -- processPart $$ iter
764 -- :: Iteratee MatchInfo m (Step ByteString m a)
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
765 innerStep <- processPart $$ iter
766
767 -- output :: Maybe a
768 output <- lift $ run_ $ returnI innerStep
769
770 case output of
771 Just x -> go (D.append soFar $ D.singleton x)
772 Nothing -> return $ D.toList soFar
773
5b05b45 @mightybyte Style cleanup
mightybyte authored
774 bParser = iterateeDebugWrapper "boundary debugger" $
775 iterParser $ pBoundaryEnd
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
776
777 pBoundaryEnd = (eol *> pure False) <|> (string "--" *> pure True)
778
779
780 ------------------------------------------------------------------------------
781 eol :: Parser ByteString
782 eol = (string "\n") <|> (string "\r\n")
783
784
785 ------------------------------------------------------------------------------
786 pHeadersWithSeparator :: Parser [(ByteString,ByteString)]
787 pHeadersWithSeparator = pHeaders <* crlf
788
789
790 ------------------------------------------------------------------------------
791 toHeaders :: [(ByteString,ByteString)] -> Headers
792 toHeaders kvps = foldl' f Map.empty kvps'
793 where
af0a9be @basvandijk Use case-insensitive instead of CIByteString
basvandijk authored
794 kvps' = map (first CI.mk . second (:[])) kvps
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
795 f m (k,v) = Map.insertWith' (flip (++)) k v m
796
797
798 ------------------------------------------------------------------------------
799 mAX_HDRS_SIZE :: Int64
800 mAX_HDRS_SIZE = 32768
801
802
803 ------------------------------------------------------------------------------
804 -- We need some code to keep track of the files we have already successfully
5b05b45 @mightybyte Style cleanup
mightybyte authored
805 -- created in case an exception is thrown by the request body enumerator or
806 -- one of the client iteratees.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
807 data UploadedFilesState = UploadedFilesState {
5b05b45 @mightybyte Style cleanup
mightybyte authored
808 -- | This is the file which is currently being written to. If the
809 -- calling function gets an exception here, it is responsible for
810 -- closing and deleting this file.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
811 _currentFile :: Maybe (FilePath, Handle)
812
813 -- | .. and these files have already been successfully read and closed.
814 , _alreadyReadFiles :: [FilePath]
815 }
816
817
818 ------------------------------------------------------------------------------
819 emptyUploadedFilesState :: UploadedFilesState
820 emptyUploadedFilesState = UploadedFilesState Nothing []
821
822
823 ------------------------------------------------------------------------------
824 newtype UploadedFiles = UploadedFiles (IORef UploadedFilesState)
825
826
827 ------------------------------------------------------------------------------
828 newUploadedFiles :: MonadIO m => m UploadedFiles
829 newUploadedFiles = liftM UploadedFiles $
830 liftIO $ newIORef emptyUploadedFilesState
831
832
833 ------------------------------------------------------------------------------
834 cleanupUploadedFiles :: (MonadIO m) => UploadedFiles -> m ()
835 cleanupUploadedFiles (UploadedFiles stateRef) = liftIO $ do
836 state <- readIORef stateRef
837 killOpenFile state
838 mapM_ killFile $ _alreadyReadFiles state
839 writeIORef stateRef emptyUploadedFilesState
840
841 where
842 killFile = eatException . removeFile
843
844 killOpenFile state = maybe (return ())
845 (\(fp,h) -> do
846 eatException $ hClose h
847 eatException $ removeFile fp)
848 (_currentFile state)
849
850
851 ------------------------------------------------------------------------------
852 openFileForUpload :: (MonadIO m) =>
853 UploadedFiles
854 -> FilePath
855 -> m (FilePath, Handle)
856 openFileForUpload ufs@(UploadedFiles stateRef) tmpdir = liftIO $ do
857 state <- readIORef stateRef
858
5b05b45 @mightybyte Style cleanup
mightybyte authored
859 -- It should be an error to open a new file with this interface if there
860 -- is already a file handle active.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
861 when (isJust $ _currentFile state) $ do
862 cleanupUploadedFiles ufs
863 throw $ GenericFileUploadException alreadyOpenMsg
864
7ae3621 @gregorycollins Kill one of the space leaks in file upload
gregorycollins authored
865 fph@(_,h) <- openBinaryTempFile tmpdir "snap-"
866 hSetBuffering h NoBuffering
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
867
868 writeIORef stateRef $ state { _currentFile = Just fph }
869 return fph
870
871 where
872 alreadyOpenMsg =
873 T.concat [ "Internal error! UploadedFiles: "
874 , "opened new file with pre-existing open handle" ]
875
876
877 ------------------------------------------------------------------------------
878 closeActiveFile :: (MonadIO m) => UploadedFiles -> m ()
879 closeActiveFile (UploadedFiles stateRef) = liftIO $ do
880 state <- readIORef stateRef
881 let m = _currentFile state
882 maybe (return ())
883 (\(fp,h) -> do
884 eatException $ hClose h
885 writeIORef stateRef $
886 state { _currentFile = Nothing
887 , _alreadyReadFiles = fp:(_alreadyReadFiles state) })
888 m
889
890
891 ------------------------------------------------------------------------------
892 eatException :: (MonadCatchIO m) => m a -> m ()
893 eatException m =
894 (m >> return ()) `catch` (\(_ :: SomeException) -> return ())
Something went wrong with that request. Please try again.