Skip to content

HTTPS clone URL

Subversion checkout URL

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