Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 879 lines (709 sloc) 33.521 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
6d19baf @gregorycollins Twiddle file-upload docs
gregorycollins authored
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
26 module Snap.Util.FileUploads
6d19baf @gregorycollins Twiddle file-upload docs
gregorycollins authored
27 ( -- * Functions
28 handleFileUploads
29 , handleMultipart
30
31 -- * Uploaded parts
32 , PartInfo(..)
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
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
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
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 ------------------------------------------------------------------------------
300 data FileUploadException =
301 GenericFileUploadException {
302 _genericFileUploadExceptionReason :: Text
303 }
304 | forall e . (Exception e, Show e) =>
305 WrappedFileUploadException {
306 _wrappedFileUploadException :: e
307 , _wrappedFileUploadExceptionReason :: Text
308 }
309 deriving (Typeable)
310
311
312 ------------------------------------------------------------------------------
313 instance Show FileUploadException where
314 show (GenericFileUploadException r) = "File upload exception: " ++
315 T.unpack r
316 show (WrappedFileUploadException e _) = show e
317
318
319 ------------------------------------------------------------------------------
320 instance Exception FileUploadException
321
322
323 ------------------------------------------------------------------------------
324 fileUploadExceptionReason :: FileUploadException -> Text
325 fileUploadExceptionReason (GenericFileUploadException r) = r
326 fileUploadExceptionReason (WrappedFileUploadException _ r) = r
327
328
329 ------------------------------------------------------------------------------
330 uploadExceptionToException :: Exception e => e -> Text -> SomeException
331 uploadExceptionToException e r = SomeException $ WrappedFileUploadException e r
332
333
334 ------------------------------------------------------------------------------
335 uploadExceptionFromException :: Exception e => SomeException -> Maybe e
336 uploadExceptionFromException x = do
337 WrappedFileUploadException e _ <- fromException x
338 cast e
339
340
341 ------------------------------------------------------------------------------
342 data BadPartException = BadPartException { badPartExceptionReason :: Text }
343 deriving (Typeable)
344
345 instance Exception BadPartException where
346 toException e@(BadPartException r) = uploadExceptionToException e r
347 fromException = uploadExceptionFromException
348
349 instance Show BadPartException where
350 show (BadPartException s) = "Bad part: " ++ T.unpack s
351
352
353 ------------------------------------------------------------------------------
354 data PolicyViolationException = PolicyViolationException {
355 policyViolationExceptionReason :: Text
356 } deriving (Typeable)
357
358 instance Exception PolicyViolationException where
359 toException e@(PolicyViolationException r) = uploadExceptionToException e r
360 fromException = uploadExceptionFromException
361
362 instance Show PolicyViolationException where
363 show (PolicyViolationException s) = "File upload policy violation: "
364 ++ T.unpack s
365
366
367 ------------------------------------------------------------------------------
368 -- | 'UploadPolicy' controls overall policy decisions relating to
369 -- @multipart/form-data@ uploads, specifically:
370 --
371 -- * whether to treat parts without filenames as form input (reading them into
372 -- the 'rqParams' map)
373 --
374 -- * 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
375 -- read in this manner, and the maximum number of form inputs
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
376 --
377 -- * the minimum upload rate a client must maintain before we kill the
378 -- connection; if very low-bitrate uploads were allowed then a Snap server
379 -- would be vulnerable to a trivial denial-of-service using a
380 -- \"slowloris\"-type attack
381 --
382 -- * the minimum number of seconds which must elapse before we start killing
383 -- uploads for having too low an upload rate.
384 --
385 -- * the amount of time we should wait before timing out the connection
386 -- whenever we receive input from the client.
387 data UploadPolicy = UploadPolicy {
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
388 processFormInputs :: Bool
389 , maximumFormInputSize :: Int
390 , maximumNumberOfFormInputs :: Int
391 , minimumUploadRate :: Double
392 , minimumUploadSeconds :: Int
393 , uploadTimeout :: Int
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
394 } deriving (Show, Eq)
395
396
397 ------------------------------------------------------------------------------
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
398 -- | A reasonable set of defaults for upload policy. The default policy is:
399 --
400 -- [@maximum form input size@] 128kB
401 --
402 -- [@maximum number of form inputs@] 10
403 --
404 -- [@minimum upload rate@] 1kB/s
405 --
406 -- [@seconds before rate limiting kicks in@] 10
407 --
408 -- [@inactivity timeout@] 20 seconds
409 --
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
410 defaultUploadPolicy :: UploadPolicy
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
411 defaultUploadPolicy = UploadPolicy True maxSize maxNum minRate minSeconds tout
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
412 where
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
413 maxSize = 2^(17::Int)
414 maxNum = 10
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
415 minRate = 1000
416 minSeconds = 10
417 tout = 20
418
419
420 ------------------------------------------------------------------------------
421 -- | Does this upload policy stipulate that we want to treat parts without
6d19baf @gregorycollins Twiddle file-upload docs
gregorycollins authored
422 -- filenames as form input?
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
423 doProcessFormInputs :: UploadPolicy -> Bool
424 doProcessFormInputs = processFormInputs
425
426
427 ------------------------------------------------------------------------------
428 -- | Set the upload policy for treating parts without filenames as form input.
429 setProcessFormInputs :: Bool -> UploadPolicy -> UploadPolicy
430 setProcessFormInputs b u = u { processFormInputs = b }
431
432
433 ------------------------------------------------------------------------------
434 -- | Get the maximum size of a form input which will be read into our
435 -- 'rqParams' map.
436 getMaximumFormInputSize :: UploadPolicy -> Int
437 getMaximumFormInputSize = maximumFormInputSize
438
439
440 ------------------------------------------------------------------------------
441 -- | Set the maximum size of a form input which will be read into our
442 -- 'rqParams' map.
443 setMaximumFormInputSize :: Int -> UploadPolicy -> UploadPolicy
444 setMaximumFormInputSize s u = u { maximumFormInputSize = s }
445
446
447 ------------------------------------------------------------------------------
448 -- | Get the minimum rate (in /bytes\/second/) a client must maintain before
449 -- we kill the connection.
450 getMinimumUploadRate :: UploadPolicy -> Double
451 getMinimumUploadRate = minimumUploadRate
452
453
454 ------------------------------------------------------------------------------
455 -- | Set the minimum rate (in /bytes\/second/) a client must maintain before
456 -- we kill the connection.
457 setMinimumUploadRate :: Double -> UploadPolicy -> UploadPolicy
458 setMinimumUploadRate s u = u { minimumUploadRate = s }
459
460
461 ------------------------------------------------------------------------------
462 -- | Get the amount of time which must elapse before we begin enforcing the
463 -- upload rate minimum
464 getMinimumUploadSeconds :: UploadPolicy -> Int
465 getMinimumUploadSeconds = minimumUploadSeconds
466
467
468 ------------------------------------------------------------------------------
469 -- | Set the amount of time which must elapse before we begin enforcing the
470 -- upload rate minimum
471 setMinimumUploadSeconds :: Int -> UploadPolicy -> UploadPolicy
472 setMinimumUploadSeconds s u = u { minimumUploadSeconds = s }
473
474
475 ------------------------------------------------------------------------------
476 -- | Get the \"upload timeout\". Whenever input is received from the client,
477 -- the connection timeout is set this many seconds in the future.
478 getUploadTimeout :: UploadPolicy -> Int
479 getUploadTimeout = uploadTimeout
480
481
482 ------------------------------------------------------------------------------
483 -- | Set the upload timeout.
484 setUploadTimeout :: Int -> UploadPolicy -> UploadPolicy
485 setUploadTimeout s u = u { uploadTimeout = s }
486
487
488 ------------------------------------------------------------------------------
489 -- | Upload policy can be set on an \"general\" basis (using 'UploadPolicy'),
490 -- but handlers can also make policy decisions on individual files\/parts
491 -- uploaded. For each part uploaded, handlers can decide:
492 --
493 -- * whether to allow the file upload at all
494 --
495 -- * the maximum size of uploaded files, if allowed
496 data PartUploadPolicy = PartUploadPolicy {
497 _maximumFileSize :: Maybe Int64
498 } deriving (Show, Eq)
499
500
501 ------------------------------------------------------------------------------
502 -- | Disallows the file to be uploaded.
503 disallow :: PartUploadPolicy
504 disallow = PartUploadPolicy Nothing
505
506
507 ------------------------------------------------------------------------------
508 -- | Allows the file to be uploaded, with maximum size /n/.
509 allowWithMaximumSize :: Int64 -> PartUploadPolicy
510 allowWithMaximumSize = PartUploadPolicy . Just
511
512
513 ------------------------------------------------------------------------------
6b4fe70 @gregorycollins Add max # of form inputs, massage docs
gregorycollins authored
514 -- private exports follow. FIXME: organize
1774737 @gregorycollins Integrate file upload support into snap-core.
gregorycollins authored
515 ------------------------------------------------------------------------------
516
517 ------------------------------------------------------------------------------
518 captureVariableOrReadFile ::
519 Int -- ^ maximum size of form input
520 -> (PartInfo -> Iteratee ByteString IO a) -- ^ file reading code
521 -> (PartInfo -> Iteratee ByteString IO (Capture a))
522 captureVariableOrReadFile maxSize fileHandler partInfo =
523 case partFileName partInfo of
524 Nothing -> iter
525 _ -> liftM File $ fileHandler partInfo
526 where
527 iter = varIter `catchError` handler
528
529 fieldName = partFieldName partInfo
530
531 varIter = do
532 var <- liftM S.concat $
533 joinI' $
534 takeNoMoreThan (fromIntegral maxSize) $$ consume
535 return $ Capture fieldName var
536
537 handler e = do
538 let m = fromException e :: Maybe TooManyBytesReadException
539 case m of
540 Nothing -> throwError e
541 Just _ -> throwError $ PolicyViolationException $
542 T.concat [ "form input '"
543 , TE.decodeUtf8 fieldName
544 , "' exceeded maximum permissible size ("
545 , T.pack $ show maxSize
546 , " bytes)" ]
547
548
549 ------------------------------------------------------------------------------
550 data Capture a = Capture ByteString ByteString
551 | File a
552 deriving (Show)
553
554
555 ------------------------------------------------------------------------------
556 fileReader :: UploadedFiles
557 -> FilePath
558 -> PartInfo
559 -> Iteratee ByteString IO (PartInfo, FilePath)
560 fileReader uploadedFiles tmpdir partInfo = do
561 (fn, h) <- openFileForUpload uploadedFiles tmpdir
562 let i = iterateeDebugWrapper "fileReader" $ iter fn h
563 i `catch` \(e::SomeException) -> throwError e
564
565 where
566 iter fileName h = do
567 iterHandle h
568 debug "fileReader: closing active file"
569 closeActiveFile uploadedFiles
570 return (partInfo, fileName)
571
572
573 ------------------------------------------------------------------------------
574 internalHandleMultipart ::
575 ByteString -- ^ boundary value
576 -> (PartInfo -> Iteratee ByteString IO a) -- ^ part processor
577 -> Iteratee ByteString IO [a]
578 internalHandleMultipart boundary clientHandler = go `catch` errorHandler
579
580 where
581 --------------------------------------------------------------------------
582 errorHandler :: SomeException -> Iteratee ByteString IO a
583 errorHandler e = do
584 skipToEof
585 throwError e
586
587 --------------------------------------------------------------------------
588 go = do
589 -- swallow the first boundary
590 _ <- iterParser $ parseFirstBoundary boundary
591 step <- iterateeDebugWrapper "kmp" $
592 (kmpEnumeratee (fullBoundary boundary) $$ processParts iter)
593 liftM concat $ lift $ run_ $ returnI step
594
595 --------------------------------------------------------------------------
596 pBoundary b = Atto.try $ do
597 _ <- string "--"
598 string b
599
600 --------------------------------------------------------------------------
601 fullBoundary b = S.concat ["\r\n", "--", b]
602 pLine = takeWhile (not . isEndOfLine . c2w) <* eol
603 takeLine = pLine *> pure ()
604 parseFirstBoundary b = pBoundary b <|> (takeLine *> parseFirstBoundary b)
605
606
607 --------------------------------------------------------------------------
608 takeHeaders = hdrs `catchError` handler
609 where
610 hdrs = liftM toHeaders $
611 iterateeDebugWrapper "header parser" $
612 joinI' $
613 takeNoMoreThan mAX_HDRS_SIZE $$
614 iterParser pHeadersWithSeparator
615
616 handler e = do
617 let m = fromException e :: Maybe TooManyBytesReadException
618 case m of
619 Nothing -> throwError e
620 Just _ -> throwError $ BadPartException $
621 "headers exceeded maximum size"
622
623 --------------------------------------------------------------------------
624 iter = do
625 hdrs <- takeHeaders
626
627 -- are we using mixed?
628 let (contentType, mboundary) = getContentType hdrs
629
630 let (fieldName, fileName) = getFieldName hdrs
631
632 if contentType == "multipart/mixed"
633 then maybe (throwError $ BadPartException $
634 "got multipart/mixed without boundary")
635 (processMixed fieldName)
636 mboundary
637 else do
638 let info = PartInfo fieldName fileName contentType
639 liftM (:[]) $ clientHandler info
640
641
642 --------------------------------------------------------------------------
643 processMixed fieldName mixedBoundary = do
644 -- swallow the first boundary
645 _ <- iterParser $ parseFirstBoundary mixedBoundary
646 step <- iterateeDebugWrapper "kmp" $
647 (kmpEnumeratee (fullBoundary mixedBoundary) $$
648 processParts (mixedIter fieldName))
649 lift $ run_ $ returnI step
650
651
652 --------------------------------------------------------------------------
653 mixedIter fieldName = do
654 hdrs <- takeHeaders
655
656 let (contentType, _) = getContentType hdrs
657 let (_, fileName) = getFieldName hdrs
658
659 let info = PartInfo fieldName fileName contentType
660 clientHandler info
661
662
663 ------------------------------------------------------------------------------
664 getContentType :: Headers
665 -> (ByteString, Maybe ByteString)
666 getContentType hdrs = (contentType, boundary)
667 where
668 contentTypeValue = fromMaybe "text/plain" $
669 getHeader "content-type" hdrs
670
671 eCT = fullyParse contentTypeValue pContentTypeWithParameters
672 (contentType, params) = either (const ("text/plain", [])) id eCT
673
674 boundary = findParam "boundary" params
675
676
677 ------------------------------------------------------------------------------
678 getFieldName :: Headers -> (ByteString, Maybe ByteString)
679 getFieldName hdrs = (fieldName, fileName)
680 where
681 contentDispositionValue = fromMaybe "" $
682 getHeader "content-disposition" hdrs
683
684 eDisposition = fullyParse contentDispositionValue pValueWithParameters
685
686 (_, dispositionParameters) =
687 either (const ("", [])) id eDisposition
688
689 fieldName = fromMaybe "" $ findParam "name" dispositionParameters
690
691 fileName = findParam "filename" dispositionParameters
692
693
694 ------------------------------------------------------------------------------
695 findParam :: (Eq a) => a -> [(a, b)] -> Maybe b
696 findParam p = fmap snd . find ((== p) . fst)
697
698
699 ------------------------------------------------------------------------------
700 -- | Given a 'MatchInfo' stream which is partitioned by boundary values, read
701 -- up until the next boundary and send all of the chunks into the wrapped
702 -- iteratee
703 processPart :: (Monad m) => Enumeratee MatchInfo ByteString m a
704 processPart = checkDone go
705 where
706 go :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
707 -> Iteratee MatchInfo m (Step ByteString m a)
708 go k = I.head >>= maybe (finish k) (process k)
709
710 -- called when outer stream is EOF
711 finish :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
712 -> Iteratee MatchInfo m (Step ByteString m a)
713 finish k = lift $ runIteratee $ k EOF
714
715 -- no match ==> pass the stream chunk along
716 process :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
717 -> MatchInfo
718 -> Iteratee MatchInfo m (Step ByteString m a)
719 process k (NoMatch s) = do
720 step <- lift $ runIteratee $ k $ Chunks [s]
721 checkDone go step
722
723 process k (Match _) = lift $ runIteratee $ k EOF
724
725
726 ------------------------------------------------------------------------------
727 -- | Assuming we've already identified the boundary value and run
728 -- 'kmpEnumeratee' to split the input up into parts which match and parts which
729 -- don't, run the given 'ByteString' iteratee over each part and grab a list of
730 -- the resulting values.
731 processParts :: Iteratee ByteString IO a
732 -> Iteratee MatchInfo IO [a]
733 processParts partIter = iterateeDebugWrapper "processParts" $ go D.empty
734 where
735 iter = do
736 isLast <- bParser
737 if isLast
738 then return Nothing
739 else do
740 x <- partIter
741 skipToEof
742 return $ Just x
743
744 go soFar = do
745 b <- isEOF
746
747 if b
748 then return $ D.toList soFar
749 else do
750 -- processPart $$ iter :: Iteratee MatchInfo m (Step ByteString m a)
751 innerStep <- processPart $$ iter
752
753 -- output :: Maybe a
754 output <- lift $ run_ $ returnI innerStep
755
756 case output of
757 Just x -> go (D.append soFar $ D.singleton x)
758 Nothing -> return $ D.toList soFar
759
760 bParser = iterateeDebugWrapper "boundary debugger" $ iterParser $ pBoundaryEnd
761
762 pBoundaryEnd = (eol *> pure False) <|> (string "--" *> pure True)
763
764
765 ------------------------------------------------------------------------------
766 eol :: Parser ByteString
767 eol = (string "\n") <|> (string "\r\n")
768
769
770 ------------------------------------------------------------------------------
771 pHeadersWithSeparator :: Parser [(ByteString,ByteString)]
772 pHeadersWithSeparator = pHeaders <* crlf
773
774
775 ------------------------------------------------------------------------------
776 toHeaders :: [(ByteString,ByteString)] -> Headers
777 toHeaders kvps = foldl' f Map.empty kvps'
778 where
779 kvps' = map (first toCI . second (:[])) kvps
780 f m (k,v) = Map.insertWith' (flip (++)) k v m
781
782
783 ------------------------------------------------------------------------------
784 mAX_HDRS_SIZE :: Int64
785 mAX_HDRS_SIZE = 32768
786
787
788 ------------------------------------------------------------------------------
789 -- We need some code to keep track of the files we have already successfully
790 -- created in case an exception is thrown by the request body enumerator or one
791 -- of the client iteratees.
792 data UploadedFilesState = UploadedFilesState {
793 -- | This is the file which is currently being written to. If the calling
794 -- function gets an exception here, it is responsible for closing and
795 -- deleting this file.
796 _currentFile :: Maybe (FilePath, Handle)
797
798 -- | .. and these files have already been successfully read and closed.
799 , _alreadyReadFiles :: [FilePath]
800 }
801
802
803 ------------------------------------------------------------------------------
804 emptyUploadedFilesState :: UploadedFilesState
805 emptyUploadedFilesState = UploadedFilesState Nothing []
806
807
808 ------------------------------------------------------------------------------
809 newtype UploadedFiles = UploadedFiles (IORef UploadedFilesState)
810
811
812 ------------------------------------------------------------------------------
813 newUploadedFiles :: MonadIO m => m UploadedFiles
814 newUploadedFiles = liftM UploadedFiles $
815 liftIO $ newIORef emptyUploadedFilesState
816
817
818 ------------------------------------------------------------------------------
819 cleanupUploadedFiles :: (MonadIO m) => UploadedFiles -> m ()
820 cleanupUploadedFiles (UploadedFiles stateRef) = liftIO $ do
821 state <- readIORef stateRef
822 killOpenFile state
823 mapM_ killFile $ _alreadyReadFiles state
824 writeIORef stateRef emptyUploadedFilesState
825
826 where
827 killFile = eatException . removeFile
828
829 killOpenFile state = maybe (return ())
830 (\(fp,h) -> do
831 eatException $ hClose h
832 eatException $ removeFile fp)
833 (_currentFile state)
834
835
836 ------------------------------------------------------------------------------
837 openFileForUpload :: (MonadIO m) =>
838 UploadedFiles
839 -> FilePath
840 -> m (FilePath, Handle)
841 openFileForUpload ufs@(UploadedFiles stateRef) tmpdir = liftIO $ do
842 state <- readIORef stateRef
843
844 -- It should be an error to open a new file with this interface if there is
845 -- already a file handle active.
846 when (isJust $ _currentFile state) $ do
847 cleanupUploadedFiles ufs
848 throw $ GenericFileUploadException alreadyOpenMsg
849
850 fph <- openTempFile tmpdir "snap-"
851
852 writeIORef stateRef $ state { _currentFile = Just fph }
853 return fph
854
855 where
856 alreadyOpenMsg =
857 T.concat [ "Internal error! UploadedFiles: "
858 , "opened new file with pre-existing open handle" ]
859
860
861 ------------------------------------------------------------------------------
862 closeActiveFile :: (MonadIO m) => UploadedFiles -> m ()
863 closeActiveFile (UploadedFiles stateRef) = liftIO $ do
864 state <- readIORef stateRef
865 let m = _currentFile state
866 maybe (return ())
867 (\(fp,h) -> do
868 eatException $ hClose h
869 writeIORef stateRef $
870 state { _currentFile = Nothing
871 , _alreadyReadFiles = fp:(_alreadyReadFiles state) })
872 m
873
874
875 ------------------------------------------------------------------------------
876 eatException :: (MonadCatchIO m) => m a -> m ()
877 eatException m =
878 (m >> return ()) `catch` (\(_ :: SomeException) -> return ())
Something went wrong with that request. Please try again.