Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

919 lines (750 sloc) 35.101 kB
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
------------------------------------------------------------------------------
-- | This module contains primitives and helper functions for handling
-- requests with @Content-type: multipart/form-data@, i.e. HTML forms and file
-- uploads.
--
-- Typically most users will want to use 'handleFileUploads', which writes
-- uploaded files to a temporary directory before sending them on to a handler
-- specified by the user.
--
-- Users who wish to handle their file uploads differently can use the
-- lower-level streaming 'Iteratee' interface called 'handleMultipart'. That
-- function takes uploaded files and streams them to an 'Iteratee' consumer of
-- the user's choosing.
--
-- Using these functions requires making \"policy\" decisions which Snap can't
-- really make for users, such as \"what's the largest PDF file a user is
-- allowed to upload?\" and \"should we read form inputs into the parameters
-- mapping?\". Policy is specified on a \"global\" basis (using
-- 'UploadPolicy'), and on a per-file basis (using 'PartUploadPolicy', which
-- allows you to reject or limit the size of certain uploaded
-- @Content-type@s).
module Snap.Util.FileUploads
( -- * Functions
handleFileUploads
, handleMultipart
-- * Uploaded parts
, PartInfo(..)
-- ** Policy
-- *** General upload policy
, UploadPolicy
, defaultUploadPolicy
, doProcessFormInputs
, setProcessFormInputs
, getMaximumFormInputSize
, setMaximumFormInputSize
, getMinimumUploadRate
, setMinimumUploadRate
, getMinimumUploadSeconds
, setMinimumUploadSeconds
, getUploadTimeout
, setUploadTimeout
-- *** Per-file upload policy
, PartUploadPolicy
, disallow
, allowWithMaximumSize
-- * Exceptions
, FileUploadException
, fileUploadExceptionReason
, BadPartException
, badPartExceptionReason
, PolicyViolationException
, policyViolationExceptionReason
) where
------------------------------------------------------------------------------
import Control.Arrow
import Control.Applicative
import Control.Exception (SomeException(..))
import Control.Monad
import Control.Monad.CatchIO
import Control.Monad.Trans
import qualified Data.Attoparsec.Char8 as Atto
import Data.Attoparsec.Char8 hiding (many, Result(..))
import Data.Attoparsec.Enumerator
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Internal (c2w)
import qualified Data.CaseInsensitive as CI
import qualified Data.DList as D
import Data.Enumerator.Binary (iterHandle)
import Data.IORef
import Data.Int
import Data.List hiding (takeWhile)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import Data.Typeable
import Prelude hiding (catch, getLine, takeWhile)
import System.Directory
import System.IO hiding (isEOF)
------------------------------------------------------------------------------
import Snap.Iteratee hiding (map)
import qualified Snap.Iteratee as I
import Snap.Internal.Debug
import Snap.Internal.Iteratee.Debug
import Snap.Internal.Iteratee.BoyerMooreHorspool
import Snap.Internal.Parsing
import Snap.Types
------------------------------------------------------------------------------
-- | Reads uploaded files into a temporary directory and calls a user handler
-- to process them.
--
-- Given a temporary directory, global and file-specific upload policies, and
-- a user handler, this function consumes a request body uploaded with
-- @Content-type: multipart/form-data@. Each file is read into the temporary
-- directory, and then a list of the uploaded files is passed to the user
-- handler. After the user handler runs (but before the 'Response' body
-- 'Enumerator' is streamed to the client), the files are deleted from disk;
-- so if you want to retain or use the uploaded files in the generated
-- response, you would need to move or otherwise process them.
--
-- The argument passed to the user handler is a list of:
--
-- > (PartInfo, Either PolicyViolationException FilePath)
--
-- The first half of this tuple is a 'PartInfo', which contains the
-- information the client browser sent about the given upload part (like
-- filename, content-type, etc). The second half of this tuple is an 'Either'
-- stipulating that either:
--
-- 1. the file was rejected on a policy basis because of the provided
-- 'PartUploadPolicy' handler
--
-- 2. the file was accepted and exists at the given path.
--
-- If the request's @Content-type@ was not \"@multipart/formdata@\", this
-- function skips processing using 'pass'.
--
-- If the client's upload rate passes below the configured minimum (see
-- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function
-- terminates the connection. This setting is there to protect the server
-- against slowloris-style denial of service attacks.
--
-- If the given 'UploadPolicy' stipulates that you wish form inputs to be
-- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and
-- a form input exceeds the maximum allowable size, this function will throw a
-- 'PolicyViolationException'.
--
-- If an uploaded part contains MIME headers longer than a fixed internal
-- threshold (currently 32KB), this function will throw a 'BadPartException'.
handleFileUploads ::
(MonadSnap m) =>
FilePath -- ^ temporary directory
-> UploadPolicy -- ^ general upload policy
-> (PartInfo -> PartUploadPolicy) -- ^ per-part upload policy
-> ([(PartInfo, Either PolicyViolationException FilePath)] -> m a)
-- ^ user handler (see function
-- description)
-> m a
handleFileUploads tmpdir uploadPolicy partPolicy handler = do
uploadedFiles <- newUploadedFiles
(do
xs <- handleMultipart uploadPolicy (iter uploadedFiles)
handler xs
) `finally` (cleanupUploadedFiles uploadedFiles)
where
iter uploadedFiles partInfo = maybe disallowed takeIt mbFs
where
ctText = partContentType partInfo
fnText = fromMaybe "" $ partFileName partInfo
ct = TE.decodeUtf8 ctText
fn = TE.decodeUtf8 fnText
(PartUploadPolicy mbFs) = partPolicy partInfo
retVal (_,x) = (partInfo, Right x)
takeIt maxSize = do
debug "handleFileUploads/takeIt: begin"
let it = fmap retVal $
joinI' $
iterateeDebugWrapper "takeNoMoreThan" $
takeNoMoreThan maxSize $$
fileReader uploadedFiles tmpdir partInfo
it `catches` [
Handler $ \(_ :: TooManyBytesReadException) -> do
debug $ "handleFileUploads/iter: " ++
"caught TooManyBytesReadException"
skipToEof
tooMany maxSize
, Handler $ \(e :: SomeException) -> do
debug $ "handleFileUploads/iter: caught " ++ show e
debug "handleFileUploads/iter: rethrowing"
throw e
]
tooMany maxSize =
return ( partInfo
, Left $ PolicyViolationException
$ T.concat [ "File \""
, fn
, "\" exceeded maximum allowable size "
, T.pack $ show maxSize ] )
disallowed =
return ( partInfo
, Left $ PolicyViolationException
$ T.concat [ "Policy disallowed upload of file \""
, fn
, "\" with content-type \""
, ct
, "\"" ] )
------------------------------------------------------------------------------
-- | Given an upload policy and a function to consume uploaded \"parts\",
-- consume a request body uploaded with @Content-type: multipart/form-data@.
-- Normally most users will want to use 'handleFileUploads' (which writes
-- uploaded files to a temporary directory and passes their names to a given
-- handler) rather than this function; the lower-level 'handleMultipart'
-- function should be used if you want to stream uploaded files to your own
-- iteratee function.
--
-- If the request's @Content-type@ was not \"@multipart/formdata@\", this
-- function skips processing using 'pass'.
--
-- If the client's upload rate passes below the configured minimum (see
-- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function
-- terminates the connection. This setting is there to protect the server
-- against slowloris-style denial of service attacks.
--
-- If the given 'UploadPolicy' stipulates that you wish form inputs to be
-- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and
-- a form input exceeds the maximum allowable size, this function will throw a
-- 'PolicyViolationException'.
--
-- If an uploaded part contains MIME headers longer than a fixed internal
-- threshold (currently 32KB), this function will throw a 'BadPartException'.
--
handleMultipart ::
(MonadSnap m) =>
UploadPolicy -- ^ global upload policy
-> (PartInfo -> Iteratee ByteString IO a) -- ^ part processor
-> m [a]
handleMultipart uploadPolicy origPartHandler = do
hdrs <- liftM headers getRequest
let (ct, mbBoundary) = getContentType hdrs
tickleTimeout <- getTimeoutAction
let bumpTimeout = tickleTimeout $ uploadTimeout uploadPolicy
let partHandler = if doProcessFormInputs uploadPolicy
then captureVariableOrReadFile
(getMaximumFormInputSize uploadPolicy)
origPartHandler
else (\p -> fmap File (origPartHandler p))
-- not well-formed multipart? bomb out.
when (ct /= "multipart/form-data") $ do
debug $ "handleMultipart called with content-type=" ++ S.unpack ct
++ ", passing"
pass
when (isNothing mbBoundary) $
throw $ BadPartException $
"got multipart/form-data without boundary"
let boundary = fromJust mbBoundary
captures <- runRequestBody (iter bumpTimeout boundary partHandler)
procCaptures [] captures
where
rateLimit bump m =
killIfTooSlow bump
(minimumUploadRate uploadPolicy)
(minimumUploadSeconds uploadPolicy)
m
`catchError` \e -> do
debug $ "rateLimit: caught " ++ show e
let (me::Maybe RateTooSlowException) = fromException e
maybe (throwError e)
terminateConnection
me
iter bump boundary ph = iterateeDebugWrapper "killIfTooSlow" $
rateLimit bump $
internalHandleMultipart boundary ph
ins k v = Map.insertWith' (\a b -> Prelude.head a : b) k [v]
maxFormVars = maximumNumberOfFormInputs uploadPolicy
procCaptures l [] = return $ reverse l
procCaptures l ((File x):xs) = procCaptures (x:l) xs
procCaptures l ((Capture k v):xs) = do
rq <- getRequest
let n = Map.size $ rqParams rq
when (n >= maxFormVars) $
throw $ PolicyViolationException $
T.concat [ "number of form inputs exceeded maximum of "
, T.pack $ show maxFormVars ]
modifyRequest $ rqModifyParams (ins k v)
procCaptures l xs
------------------------------------------------------------------------------
-- | 'PartInfo' contains information about a \"part\" in a request uploaded
-- with @Content-type: multipart/form-data@.
data PartInfo =
PartInfo { partFieldName :: !ByteString
, partFileName :: !(Maybe ByteString)
, partContentType :: !ByteString
}
deriving (Show)
------------------------------------------------------------------------------
-- | All of the exceptions defined in this package inherit from
-- 'FileUploadException', so if you write
--
-- > foo `catch` \(e :: FileUploadException) -> ...
--
-- you can catch a 'BadPartException', a 'PolicyViolationException', etc.
data FileUploadException =
GenericFileUploadException {
_genericFileUploadExceptionReason :: Text
}
| forall e . (Exception e, Show e) =>
WrappedFileUploadException {
_wrappedFileUploadException :: e
, _wrappedFileUploadExceptionReason :: Text
}
deriving (Typeable)
------------------------------------------------------------------------------
instance Show FileUploadException where
show (GenericFileUploadException r) = "File upload exception: " ++
T.unpack r
show (WrappedFileUploadException e _) = show e
------------------------------------------------------------------------------
instance Exception FileUploadException
------------------------------------------------------------------------------
fileUploadExceptionReason :: FileUploadException -> Text
fileUploadExceptionReason (GenericFileUploadException r) = r
fileUploadExceptionReason (WrappedFileUploadException _ r) = r
------------------------------------------------------------------------------
uploadExceptionToException :: Exception e => e -> Text -> SomeException
uploadExceptionToException e r =
SomeException $ WrappedFileUploadException e r
------------------------------------------------------------------------------
uploadExceptionFromException :: Exception e => SomeException -> Maybe e
uploadExceptionFromException x = do
WrappedFileUploadException e _ <- fromException x
cast e
------------------------------------------------------------------------------
data BadPartException = BadPartException { badPartExceptionReason :: Text }
deriving (Typeable)
instance Exception BadPartException where
toException e@(BadPartException r) = uploadExceptionToException e r
fromException = uploadExceptionFromException
instance Show BadPartException where
show (BadPartException s) = "Bad part: " ++ T.unpack s
------------------------------------------------------------------------------
data PolicyViolationException = PolicyViolationException {
policyViolationExceptionReason :: Text
} deriving (Typeable)
instance Exception PolicyViolationException where
toException e@(PolicyViolationException r) =
uploadExceptionToException e r
fromException = uploadExceptionFromException
instance Show PolicyViolationException where
show (PolicyViolationException s) = "File upload policy violation: "
++ T.unpack s
------------------------------------------------------------------------------
-- | 'UploadPolicy' controls overall policy decisions relating to
-- @multipart/form-data@ uploads, specifically:
--
-- * whether to treat parts without filenames as form input (reading them into
-- the 'rqParams' map)
--
-- * because form input is read into memory, the maximum size of a form input
-- read in this manner, and the maximum number of form inputs
--
-- * the minimum upload rate a client must maintain before we kill the
-- connection; if very low-bitrate uploads were allowed then a Snap server
-- would be vulnerable to a trivial denial-of-service using a
-- \"slowloris\"-type attack
--
-- * the minimum number of seconds which must elapse before we start killing
-- uploads for having too low an upload rate.
--
-- * the amount of time we should wait before timing out the connection
-- whenever we receive input from the client.
data UploadPolicy = UploadPolicy {
processFormInputs :: Bool
, maximumFormInputSize :: Int64
, maximumNumberOfFormInputs :: Int
, minimumUploadRate :: Double
, minimumUploadSeconds :: Int
, uploadTimeout :: Int
} deriving (Show, Eq)
------------------------------------------------------------------------------
-- | A reasonable set of defaults for upload policy. The default policy is:
--
-- [@maximum form input size@] 128kB
--
-- [@maximum number of form inputs@] 10
--
-- [@minimum upload rate@] 1kB/s
--
-- [@seconds before rate limiting kicks in@] 10
--
-- [@inactivity timeout@] 20 seconds
--
defaultUploadPolicy :: UploadPolicy
defaultUploadPolicy = UploadPolicy True maxSize maxNum minRate minSeconds tout
where
maxSize = 2^(17::Int)
maxNum = 10
minRate = 1000
minSeconds = 10
tout = 20
------------------------------------------------------------------------------
-- | Does this upload policy stipulate that we want to treat parts without
-- filenames as form input?
doProcessFormInputs :: UploadPolicy -> Bool
doProcessFormInputs = processFormInputs
------------------------------------------------------------------------------
-- | Set the upload policy for treating parts without filenames as form input.
setProcessFormInputs :: Bool -> UploadPolicy -> UploadPolicy
setProcessFormInputs b u = u { processFormInputs = b }
------------------------------------------------------------------------------
-- | Get the maximum size of a form input which will be read into our
-- 'rqParams' map.
getMaximumFormInputSize :: UploadPolicy -> Int64
getMaximumFormInputSize = maximumFormInputSize
------------------------------------------------------------------------------
-- | Set the maximum size of a form input which will be read into our
-- 'rqParams' map.
setMaximumFormInputSize :: Int64 -> UploadPolicy -> UploadPolicy
setMaximumFormInputSize s u = u { maximumFormInputSize = s }
------------------------------------------------------------------------------
-- | Get the minimum rate (in /bytes\/second/) a client must maintain before
-- we kill the connection.
getMinimumUploadRate :: UploadPolicy -> Double
getMinimumUploadRate = minimumUploadRate
------------------------------------------------------------------------------
-- | Set the minimum rate (in /bytes\/second/) a client must maintain before
-- we kill the connection.
setMinimumUploadRate :: Double -> UploadPolicy -> UploadPolicy
setMinimumUploadRate s u = u { minimumUploadRate = s }
------------------------------------------------------------------------------
-- | Get the amount of time which must elapse before we begin enforcing the
-- upload rate minimum
getMinimumUploadSeconds :: UploadPolicy -> Int
getMinimumUploadSeconds = minimumUploadSeconds
------------------------------------------------------------------------------
-- | Set the amount of time which must elapse before we begin enforcing the
-- upload rate minimum
setMinimumUploadSeconds :: Int -> UploadPolicy -> UploadPolicy
setMinimumUploadSeconds s u = u { minimumUploadSeconds = s }
------------------------------------------------------------------------------
-- | Get the \"upload timeout\". Whenever input is received from the client,
-- the connection timeout is set this many seconds in the future.
getUploadTimeout :: UploadPolicy -> Int
getUploadTimeout = uploadTimeout
------------------------------------------------------------------------------
-- | Set the upload timeout.
setUploadTimeout :: Int -> UploadPolicy -> UploadPolicy
setUploadTimeout s u = u { uploadTimeout = s }
------------------------------------------------------------------------------
-- | Upload policy can be set on an \"general\" basis (using 'UploadPolicy'),
-- but handlers can also make policy decisions on individual files\/parts
-- uploaded. For each part uploaded, handlers can decide:
--
-- * whether to allow the file upload at all
--
-- * the maximum size of uploaded files, if allowed
data PartUploadPolicy = PartUploadPolicy {
_maximumFileSize :: Maybe Int64
} deriving (Show, Eq)
------------------------------------------------------------------------------
-- | Disallows the file to be uploaded.
disallow :: PartUploadPolicy
disallow = PartUploadPolicy Nothing
------------------------------------------------------------------------------
-- | Allows the file to be uploaded, with maximum size /n/.
allowWithMaximumSize :: Int64 -> PartUploadPolicy
allowWithMaximumSize = PartUploadPolicy . Just
------------------------------------------------------------------------------
-- private exports follow. FIXME: organize
------------------------------------------------------------------------------
------------------------------------------------------------------------------
captureVariableOrReadFile ::
Int64 -- ^ maximum size of form input
-> (PartInfo -> Iteratee ByteString IO a) -- ^ file reading code
-> (PartInfo -> Iteratee ByteString IO (Capture a))
captureVariableOrReadFile maxSize fileHandler partInfo =
case partFileName partInfo of
Nothing -> iter
_ -> liftM File $ fileHandler partInfo
where
iter = varIter `catchError` handler
fieldName = partFieldName partInfo
varIter = do
var <- liftM S.concat $
joinI' $
takeNoMoreThan maxSize $$ consume
return $ Capture fieldName var
handler e = do
debug $ "captureVariableOrReadFile/handler: caught " ++ show e
let m = fromException e :: Maybe TooManyBytesReadException
case m of
Nothing -> do
debug "didn't expect this error, rethrowing"
throwError e
Just _ -> do
debug "rethrowing as PolicyViolationException"
throwError $ PolicyViolationException $
T.concat [ "form input '"
, TE.decodeUtf8 fieldName
, "' exceeded maximum permissible size ("
, T.pack $ show maxSize
, " bytes)" ]
------------------------------------------------------------------------------
data Capture a = Capture ByteString ByteString
| File a
deriving (Show)
------------------------------------------------------------------------------
fileReader :: UploadedFiles
-> FilePath
-> PartInfo
-> Iteratee ByteString IO (PartInfo, FilePath)
fileReader uploadedFiles tmpdir partInfo = do
debug "fileReader: begin"
(fn, h) <- openFileForUpload uploadedFiles tmpdir
let i = iterateeDebugWrapper "fileReader" $ iter fn h
i `catch` \(e::SomeException) -> throwError e
where
iter fileName h = do
iterHandle h
debug "fileReader: closing active file"
closeActiveFile uploadedFiles
return (partInfo, fileName)
------------------------------------------------------------------------------
internalHandleMultipart ::
ByteString -- ^ boundary value
-> (PartInfo -> Iteratee ByteString IO a) -- ^ part processor
-> Iteratee ByteString IO [a]
internalHandleMultipart boundary clientHandler = go `catch` errorHandler
where
--------------------------------------------------------------------------
errorHandler :: SomeException -> Iteratee ByteString IO a
errorHandler e = do
skipToEof
throwError e
--------------------------------------------------------------------------
go = do
-- swallow the first boundary
_ <- iterParser $ parseFirstBoundary boundary
step <- iterateeDebugWrapper "boyer-moore" $
(bmhEnumeratee (fullBoundary boundary) $$ processParts iter)
liftM concat $ lift $ run_ $ returnI step
--------------------------------------------------------------------------
pBoundary b = Atto.try $ do
_ <- string "--"
string b
--------------------------------------------------------------------------
fullBoundary b = S.concat ["\r\n", "--", b]
pLine = takeWhile (not . isEndOfLine . c2w) <* eol
takeLine = pLine *> pure ()
parseFirstBoundary b = pBoundary b <|> (takeLine *> parseFirstBoundary b)
--------------------------------------------------------------------------
takeHeaders = hdrs `catchError` handler
where
hdrs = liftM toHeaders $
iterateeDebugWrapper "header parser" $
joinI' $
takeNoMoreThan mAX_HDRS_SIZE $$
iterParser pHeadersWithSeparator
handler e = do
debug $ "internalHandleMultipart/takeHeaders: caught " ++ show e
let m = fromException e :: Maybe TooManyBytesReadException
case m of
Nothing -> throwError e
Just _ -> throwError $ BadPartException $
"headers exceeded maximum size"
--------------------------------------------------------------------------
iter = do
hdrs <- takeHeaders
debug $ "internalHandleMultipart/iter: got headers"
-- are we using mixed?
let (contentType, mboundary) = getContentType hdrs
let (fieldName, fileName) = getFieldName hdrs
if contentType == "multipart/mixed"
then maybe (throwError $ BadPartException $
"got multipart/mixed without boundary")
(processMixed fieldName)
mboundary
else do
let info = PartInfo fieldName fileName contentType
liftM (:[]) $ clientHandler info
--------------------------------------------------------------------------
processMixed fieldName mixedBoundary = do
-- swallow the first boundary
_ <- iterParser $ parseFirstBoundary mixedBoundary
step <- iterateeDebugWrapper "boyer-moore" $
(bmhEnumeratee (fullBoundary mixedBoundary) $$
processParts (mixedIter fieldName))
lift $ run_ $ returnI step
--------------------------------------------------------------------------
mixedIter fieldName = do
hdrs <- takeHeaders
let (contentType, _) = getContentType hdrs
let (_, fileName) = getFieldName hdrs
let info = PartInfo fieldName fileName contentType
clientHandler info
------------------------------------------------------------------------------
getContentType :: Headers
-> (ByteString, Maybe ByteString)
getContentType hdrs = (contentType, boundary)
where
contentTypeValue = fromMaybe "text/plain" $
getHeader "content-type" hdrs
eCT = fullyParse contentTypeValue pContentTypeWithParameters
(contentType, params) = either (const ("text/plain", [])) id eCT
boundary = findParam "boundary" params
------------------------------------------------------------------------------
getFieldName :: Headers -> (ByteString, Maybe ByteString)
getFieldName hdrs = (fieldName, fileName)
where
contentDispositionValue = fromMaybe "" $
getHeader "content-disposition" hdrs
eDisposition = fullyParse contentDispositionValue pValueWithParameters
(_, dispositionParameters) =
either (const ("", [])) id eDisposition
fieldName = fromMaybe "" $ findParam "name" dispositionParameters
fileName = findParam "filename" dispositionParameters
------------------------------------------------------------------------------
findParam :: (Eq a) => a -> [(a, b)] -> Maybe b
findParam p = fmap snd . find ((== p) . fst)
------------------------------------------------------------------------------
-- | Given a 'MatchInfo' stream which is partitioned by boundary values, read
-- up until the next boundary and send all of the chunks into the wrapped
-- iteratee
processPart :: (Monad m) => Enumeratee MatchInfo ByteString m a
processPart st = {-# SCC "pPart/outer" #-}
case st of
(Continue k) -> go k
_ -> yield st (Chunks [])
where
go :: (Monad m) => (Stream ByteString -> Iteratee ByteString m a)
-> Iteratee MatchInfo m (Step ByteString m a)
go !k = {-# SCC "pPart/go" #-}
I.head >>= maybe finish process
where
-- called when outer stream is EOF
finish = {-# SCC "pPart/finish" #-}
lift $ runIteratee $ k EOF
-- no match ==> pass the stream chunk along
process (NoMatch !s) = {-# SCC "pPart/noMatch" #-} do
!step <- lift $ runIteratee $ k $ Chunks [s]
case step of
(Continue k') -> go k'
_ -> yield step (Chunks [])
process (Match _) = {-# SCC "pPart/match" #-}
lift $ runIteratee $ k EOF
------------------------------------------------------------------------------
-- | Assuming we've already identified the boundary value and run
-- 'bmhEnumeratee' to split the input up into parts which match and parts
-- which don't, run the given 'ByteString' iteratee over each part and grab a
-- list of the resulting values.
processParts :: Iteratee ByteString IO a
-> Iteratee MatchInfo IO [a]
processParts partIter = iterateeDebugWrapper "processParts" $ go D.empty
where
iter = {-# SCC "processParts/iter" #-} do
isLast <- bParser
if isLast
then return Nothing
else do
x <- partIter
skipToEof
return $ Just x
go soFar = {-# SCC "processParts/go" #-} do
b <- isEOF
if b
then return $ D.toList soFar
else do
-- processPart $$ iter
-- :: Iteratee MatchInfo m (Step ByteString m a)
innerStep <- processPart $$ iter
-- output :: Maybe a
output <- lift $ run_ $ returnI innerStep
case output of
Just x -> go (D.append soFar $ D.singleton x)
Nothing -> return $ D.toList soFar
bParser = iterateeDebugWrapper "boundary debugger" $
iterParser $ pBoundaryEnd
pBoundaryEnd = (eol *> pure False) <|> (string "--" *> pure True)
------------------------------------------------------------------------------
eol :: Parser ByteString
eol = (string "\n") <|> (string "\r\n")
------------------------------------------------------------------------------
pHeadersWithSeparator :: Parser [(ByteString,ByteString)]
pHeadersWithSeparator = pHeaders <* crlf
------------------------------------------------------------------------------
toHeaders :: [(ByteString,ByteString)] -> Headers
toHeaders kvps = foldl' f Map.empty kvps'
where
kvps' = map (first CI.mk . second (:[])) kvps
f m (k,v) = Map.insertWith' (flip (++)) k v m
------------------------------------------------------------------------------
mAX_HDRS_SIZE :: Int64
mAX_HDRS_SIZE = 32768
------------------------------------------------------------------------------
-- We need some code to keep track of the files we have already successfully
-- created in case an exception is thrown by the request body enumerator or
-- one of the client iteratees.
data UploadedFilesState = UploadedFilesState {
-- | This is the file which is currently being written to. If the
-- calling function gets an exception here, it is responsible for
-- closing and deleting this file.
_currentFile :: Maybe (FilePath, Handle)
-- | .. and these files have already been successfully read and closed.
, _alreadyReadFiles :: [FilePath]
}
------------------------------------------------------------------------------
emptyUploadedFilesState :: UploadedFilesState
emptyUploadedFilesState = UploadedFilesState Nothing []
------------------------------------------------------------------------------
newtype UploadedFiles = UploadedFiles (IORef UploadedFilesState)
------------------------------------------------------------------------------
newUploadedFiles :: MonadIO m => m UploadedFiles
newUploadedFiles = liftM UploadedFiles $
liftIO $ newIORef emptyUploadedFilesState
------------------------------------------------------------------------------
cleanupUploadedFiles :: (MonadIO m) => UploadedFiles -> m ()
cleanupUploadedFiles (UploadedFiles stateRef) = liftIO $ do
state <- readIORef stateRef
killOpenFile state
mapM_ killFile $ _alreadyReadFiles state
writeIORef stateRef emptyUploadedFilesState
where
killFile = eatException . removeFile
killOpenFile state = maybe (return ())
(\(fp,h) -> do
eatException $ hClose h
eatException $ removeFile fp)
(_currentFile state)
------------------------------------------------------------------------------
openFileForUpload :: (MonadIO m) =>
UploadedFiles
-> FilePath
-> m (FilePath, Handle)
openFileForUpload ufs@(UploadedFiles stateRef) tmpdir = liftIO $ do
state <- readIORef stateRef
-- It should be an error to open a new file with this interface if there
-- is already a file handle active.
when (isJust $ _currentFile state) $ do
cleanupUploadedFiles ufs
throw $ GenericFileUploadException alreadyOpenMsg
fph@(_,h) <- openBinaryTempFile tmpdir "snap-"
hSetBuffering h NoBuffering
writeIORef stateRef $ state { _currentFile = Just fph }
return fph
where
alreadyOpenMsg =
T.concat [ "Internal error! UploadedFiles: "
, "opened new file with pre-existing open handle" ]
------------------------------------------------------------------------------
closeActiveFile :: (MonadIO m) => UploadedFiles -> m ()
closeActiveFile (UploadedFiles stateRef) = liftIO $ do
state <- readIORef stateRef
let m = _currentFile state
maybe (return ())
(\(fp,h) -> do
eatException $ hClose h
writeIORef stateRef $
state { _currentFile = Nothing
, _alreadyReadFiles = fp:(_alreadyReadFiles state) })
m
------------------------------------------------------------------------------
eatException :: (MonadCatchIO m) => m a -> m ()
eatException m =
(m >> return ()) `catch` (\(_ :: SomeException) -> return ())
Jump to Line
Something went wrong with that request. Please try again.