Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 898 lines (727 sloc) 34.324 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 Data.CIByteString
76 import qualified Data.ByteString.Char8 as S
77 import Data.ByteString.Char8 (ByteString)
78 import Data.ByteString.Internal (c2w)
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-Horspool...
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-Horspool...
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-Horspool...
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
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
714 processPart _st = {-# SCC "pPart/outer" #-} cDone go _st
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
715 where
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
716 cDone !f (Continue !k) = {-# SCC "cDone/cont" #-} f k
717 cDone _ step = {-# SCC "cDone/yield" #-}
718 yield step (Chunks [])
719
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
720 go :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
721 -> Iteratee MatchInfo m (Step ByteString m a)
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
722 go !k = {-# SCC "pPart/go" #-}
723 I.head >>= maybe (finish k) (process k)
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
724
725 -- called when outer stream is EOF
726 finish :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
727 -> Iteratee MatchInfo m (Step ByteString m a)
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
728 finish !k = {-# SCC "pPart/finish" #-}
729 lift $ runIteratee $ k EOF
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
730
731 -- no match ==> pass the stream chunk along
732 process :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
733 -> MatchInfo
734 -> Iteratee MatchInfo m (Step ByteString m a)
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
735 process !k (NoMatch !s) = {-# SCC "pPart/noMatch" #-} do
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
736 step <- lift $ runIteratee $ k $ Chunks [s]
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
737 cDone go step
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
738
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
739 process !k (Match _) = {-# SCC "pPart/match" #-}
740 lift $ runIteratee $ k EOF
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
741
742
743 ------------------------------------------------------------------------------
744 -- | Assuming we've already identified the boundary value and run
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
745 -- 'bmhEnumeratee' to split the input up into parts which match and parts
5b05b45 @mightybyte Style cleanup
mightybyte authored
746 -- which don't, run the given 'ByteString' iteratee over each part and grab a
747 -- list of the resulting values.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
748 processParts :: Iteratee ByteString IO a
749 -> Iteratee MatchInfo IO [a]
750 processParts partIter = iterateeDebugWrapper "processParts" $ go D.empty
751 where
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
752 iter = {-# SCC "processParts/iter" #-} do
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
753 isLast <- bParser
754 if isLast
755 then return Nothing
756 else do
757 x <- partIter
758 skipToEof
759 return $ Just x
760
7a604e0 @gregorycollins Fix space leak in MonadCatchIO instance, substitute Boyer-Moore-Horspool...
gregorycollins authored
761 go soFar = {-# SCC "processParts/go" #-} do
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
762 b <- isEOF
763
764 if b
765 then return $ D.toList soFar
766 else do
5b05b45 @mightybyte Style cleanup
mightybyte authored
767 -- processPart $$ iter
768 -- :: Iteratee MatchInfo m (Step ByteString m a)
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
769 innerStep <- processPart $$ iter
770
771 -- output :: Maybe a
772 output <- lift $ run_ $ returnI innerStep
773
774 case output of
775 Just x -> go (D.append soFar $ D.singleton x)
776 Nothing -> return $ D.toList soFar
777
5b05b45 @mightybyte Style cleanup
mightybyte authored
778 bParser = iterateeDebugWrapper "boundary debugger" $
779 iterParser $ pBoundaryEnd
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
780
781 pBoundaryEnd = (eol *> pure False) <|> (string "--" *> pure True)
782
783
784 ------------------------------------------------------------------------------
785 eol :: Parser ByteString
786 eol = (string "\n") <|> (string "\r\n")
787
788
789 ------------------------------------------------------------------------------
790 pHeadersWithSeparator :: Parser [(ByteString,ByteString)]
791 pHeadersWithSeparator = pHeaders <* crlf
792
793
794 ------------------------------------------------------------------------------
795 toHeaders :: [(ByteString,ByteString)] -> Headers
796 toHeaders kvps = foldl' f Map.empty kvps'
797 where
798 kvps' = map (first toCI . second (:[])) kvps
799 f m (k,v) = Map.insertWith' (flip (++)) k v m
800
801
802 ------------------------------------------------------------------------------
803 mAX_HDRS_SIZE :: Int64
804 mAX_HDRS_SIZE = 32768
805
806
807 ------------------------------------------------------------------------------
808 -- We need some code to keep track of the files we have already successfully
5b05b45 @mightybyte Style cleanup
mightybyte authored
809 -- created in case an exception is thrown by the request body enumerator or
810 -- one of the client iteratees.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
811 data UploadedFilesState = UploadedFilesState {
5b05b45 @mightybyte Style cleanup
mightybyte authored
812 -- | This is the file which is currently being written to. If the
813 -- calling function gets an exception here, it is responsible for
814 -- closing and deleting this file.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
815 _currentFile :: Maybe (FilePath, Handle)
816
817 -- | .. and these files have already been successfully read and closed.
818 , _alreadyReadFiles :: [FilePath]
819 }
820
821
822 ------------------------------------------------------------------------------
823 emptyUploadedFilesState :: UploadedFilesState
824 emptyUploadedFilesState = UploadedFilesState Nothing []
825
826
827 ------------------------------------------------------------------------------
828 newtype UploadedFiles = UploadedFiles (IORef UploadedFilesState)
829
830
831 ------------------------------------------------------------------------------
832 newUploadedFiles :: MonadIO m => m UploadedFiles
833 newUploadedFiles = liftM UploadedFiles $
834 liftIO $ newIORef emptyUploadedFilesState
835
836
837 ------------------------------------------------------------------------------
838 cleanupUploadedFiles :: (MonadIO m) => UploadedFiles -> m ()
839 cleanupUploadedFiles (UploadedFiles stateRef) = liftIO $ do
840 state <- readIORef stateRef
841 killOpenFile state
842 mapM_ killFile $ _alreadyReadFiles state
843 writeIORef stateRef emptyUploadedFilesState
844
845 where
846 killFile = eatException . removeFile
847
848 killOpenFile state = maybe (return ())
849 (\(fp,h) -> do
850 eatException $ hClose h
851 eatException $ removeFile fp)
852 (_currentFile state)
853
854
855 ------------------------------------------------------------------------------
856 openFileForUpload :: (MonadIO m) =>
857 UploadedFiles
858 -> FilePath
859 -> m (FilePath, Handle)
860 openFileForUpload ufs@(UploadedFiles stateRef) tmpdir = liftIO $ do
861 state <- readIORef stateRef
862
5b05b45 @mightybyte Style cleanup
mightybyte authored
863 -- It should be an error to open a new file with this interface if there
864 -- is already a file handle active.
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
865 when (isJust $ _currentFile state) $ do
866 cleanupUploadedFiles ufs
867 throw $ GenericFileUploadException alreadyOpenMsg
868
869 fph <- openTempFile tmpdir "snap-"
870
871 writeIORef stateRef $ state { _currentFile = Just fph }
872 return fph
873
874 where
875 alreadyOpenMsg =
876 T.concat [ "Internal error! UploadedFiles: "
877 , "opened new file with pre-existing open handle" ]
878
879
880 ------------------------------------------------------------------------------
881 closeActiveFile :: (MonadIO m) => UploadedFiles -> m ()
882 closeActiveFile (UploadedFiles stateRef) = liftIO $ do
883 state <- readIORef stateRef
884 let m = _currentFile state
885 maybe (return ())
886 (\(fp,h) -> do
887 eatException $ hClose h
888 writeIORef stateRef $
889 state { _currentFile = Nothing
890 , _alreadyReadFiles = fp:(_alreadyReadFiles state) })
891 m
892
893
894 ------------------------------------------------------------------------------
895 eatException :: (MonadCatchIO m) => m a -> m ()
896 eatException m =
897 (m >> return ()) `catch` (\(_ :: SomeException) -> return ())
Something went wrong with that request. Please try again.