Skip to content

HTTPS clone URL

Subversion checkout URL

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