Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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