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