{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}

module Snap.Internal.Util.FileUploads
  ( -- * Functions
    handleFormUploads
  , foldMultipart
  , PartFold
  , FormParam
  , FormFile (..)
  , storeAsLazyByteString
  , withTemporaryStore
    -- ** Backwards compatible API
  , handleFileUploads
  , handleMultipart
  , PartProcessor

    -- * Uploaded parts
  , PartInfo(..)
  , PartDisposition(..)
  , toPartDisposition

    -- ** Policy
    -- *** General upload policy
  , UploadPolicy(..)
  , defaultUploadPolicy
  , doProcessFormInputs
  , setProcessFormInputs
  , getMaximumFormInputSize
  , setMaximumFormInputSize
  , getMaximumNumberOfFormInputs
  , setMaximumNumberOfFormInputs
  , getMinimumUploadRate
  , setMinimumUploadRate
  , getMinimumUploadSeconds
  , setMinimumUploadSeconds
  , getUploadTimeout
  , setUploadTimeout

    -- *** File upload policy
  , FileUploadPolicy(..)
  , defaultFileUploadPolicy
  , setMaximumFileSize
  , setMaximumNumberOfFiles
  , setSkipFilesWithoutNames
  , setMaximumSkippedFileSize

    -- *** Per-file upload policy
  , PartUploadPolicy(..)
  , disallow
  , allowWithMaximumSize

    -- * Exceptions
  , FileUploadException(..)
  , fileUploadExceptionReason
  , BadPartException(..)
  , PolicyViolationException(..)
  ) where

------------------------------------------------------------------------------
import           Control.Applicative              (Alternative ((<|>)), Applicative (pure, (*>), (<*)))
import           Control.Arrow                    (Arrow (first))
import           Control.Exception.Lifted         (Exception, SomeException (..), bracket, catch, finally, fromException, mask, throwIO, toException)
import qualified Control.Exception.Lifted         as E (try)
import           Control.Monad                    (Functor (fmap), Monad (return, (>>=)), MonadPlus (mzero), forM_, guard, liftM, sequence, unless, void, when, (>=>))
import           Control.Monad.IO.Class           (liftIO)
import           Data.Attoparsec.ByteString.Char8 (Parser, isEndOfLine, string, takeWhile)
import qualified Data.Attoparsec.ByteString.Char8 as Atto (try)
import           Data.ByteString.Char8            (ByteString)
import qualified Data.ByteString.Char8            as S
import           Data.ByteString.Internal         (c2w)
import qualified Data.ByteString.Lazy.Internal    as LB (ByteString (Empty), chunk)
import qualified Data.CaseInsensitive             as CI (mk)
import           Data.Int                         (Int, Int64)
import qualified Data.IORef                       as IORef
import           Data.List                        (find, map, (++))
import qualified Data.Map                         as Map (insertWith)
import           Data.Maybe                       (Maybe (..), fromMaybe, isJust, maybe)
import           Data.Text                        (Text)
import qualified Data.Text                        as T (concat, pack, unpack)
import qualified Data.Text.Encoding               as TE (decodeUtf8)
import           Data.Typeable                    (Typeable, cast)
import           Prelude                          (Bool (..), Double, Either (..), Eq (..), FilePath, IO, Ord (..), Show (..), String, const, either, foldr, fst, id, max, not, otherwise, seq, snd, succ, ($), ($!), (.), (^), (||))
import           Snap.Core                        (HasHeaders (headers), Headers, MonadSnap, Request (rqParams, rqPostParams), getHeader, getRequest, getTimeoutModifier, putRequest, runRequestBody)
import           Snap.Internal.Parsing            (crlf, fullyParse, pContentTypeWithParameters, pHeaders, pValueWithParameters')
import qualified Snap.Types.Headers               as H (fromList)
import           System.Directory                 (removeFile)
import           System.FilePath                  ((</>))
import           System.IO                        (BufferMode (NoBuffering), Handle, hClose, hSetBuffering, openBinaryTempFile)
import           System.IO.Error                  (isDoesNotExistError)
import           System.IO.Streams                (InputStream, MatchInfo (..), TooManyBytesReadException, search)
import qualified System.IO.Streams                as Streams
import           System.IO.Streams.Attoparsec     (parseFromStream)
import           System.PosixCompat.Temp          (mkstemp)
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- | Reads uploaded files into a temporary directory and calls a user handler
-- to process them.
--
-- Note: /THE REQUEST MUST BE CORRECTLY ENCODED/. If the request's
-- @Content-type@ is not \"@multipart/formdata@\", this function skips
-- processing using 'pass'.
--
-- 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 is then passed to the user handler. After the user handler
-- runs (but before the 'Response' body 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 need to move or otherwise process them.
--
-- The argument passed to the user handler is a tuple:
--
-- > (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.
--
-- /Exceptions/
--
-- 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 -> IO a)
                                      -- ^ user handler (see function
                                      -- description)
    -> m [a]
handleFileUploads :: FilePath
-> UploadPolicy
-> (PartInfo -> PartUploadPolicy)
-> (PartInfo -> Either PolicyViolationException FilePath -> IO a)
-> m [a]
handleFileUploads FilePath
tmpdir UploadPolicy
uploadPolicy PartInfo -> PartUploadPolicy
partPolicy PartInfo -> Either PolicyViolationException FilePath -> IO a
partHandler =
    UploadPolicy -> PartProcessor a -> m [a]
forall (m :: * -> *) a.
MonadSnap m =>
UploadPolicy -> PartProcessor a -> m [a]
handleMultipart UploadPolicy
uploadPolicy PartProcessor a
go

  where
    go :: PartProcessor a
go PartInfo
partInfo InputStream ByteString
stream = IO a -> (Int64 -> IO a) -> Maybe Int64 -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO a
disallowed Int64 -> IO a
takeIt Maybe Int64
mbFs
      where
        ctText :: ByteString
ctText = PartInfo -> ByteString
partContentType PartInfo
partInfo
        fnText :: ByteString
fnText = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PartInfo -> Maybe ByteString
partFileName PartInfo
partInfo

        ct :: Text
ct = ByteString -> Text
TE.decodeUtf8 ByteString
ctText
        fn :: Text
fn = ByteString -> Text
TE.decodeUtf8 ByteString
fnText

        (PartUploadPolicy Maybe Int64
mbFs) = PartInfo -> PartUploadPolicy
partPolicy PartInfo
partInfo

        takeIt :: Int64 -> IO a
takeIt Int64
maxSize = do
            InputStream ByteString
str' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
maxSize InputStream ByteString
stream
            FilePath
-> (PartInfo -> Either PolicyViolationException FilePath -> IO a)
-> PartProcessor a
forall a.
FilePath
-> (PartInfo -> Either PolicyViolationException FilePath -> IO a)
-> PartProcessor a
fileReader FilePath
tmpdir PartInfo -> Either PolicyViolationException FilePath -> IO a
partHandler PartInfo
partInfo InputStream ByteString
str' IO a -> (TooManyBytesReadException -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Int64 -> TooManyBytesReadException -> IO a
forall a. Show a => a -> TooManyBytesReadException -> IO a
tooMany Int64
maxSize

        tooMany :: a -> TooManyBytesReadException -> IO a
tooMany a
maxSize (TooManyBytesReadException
_ :: TooManyBytesReadException) =
            PartInfo -> Either PolicyViolationException FilePath -> IO a
partHandler PartInfo
partInfo
                        (PolicyViolationException
-> Either PolicyViolationException FilePath
forall a b. a -> Either a b
Left (PolicyViolationException
 -> Either PolicyViolationException FilePath)
-> PolicyViolationException
-> Either PolicyViolationException FilePath
forall a b. (a -> b) -> a -> b
$
                         Text -> PolicyViolationException
PolicyViolationException (Text -> PolicyViolationException)
-> Text -> PolicyViolationException
forall a b. (a -> b) -> a -> b
$
                         [Text] -> Text
T.concat [ Text
"File \""
                                  , Text
fn
                                  , Text
"\" exceeded maximum allowable size "
                                  , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show a
maxSize ])

        disallowed :: IO a
disallowed =
            PartInfo -> Either PolicyViolationException FilePath -> IO a
partHandler PartInfo
partInfo
                        (PolicyViolationException
-> Either PolicyViolationException FilePath
forall a b. a -> Either a b
Left (PolicyViolationException
 -> Either PolicyViolationException FilePath)
-> PolicyViolationException
-> Either PolicyViolationException FilePath
forall a b. (a -> b) -> a -> b
$
                         Text -> PolicyViolationException
PolicyViolationException (Text -> PolicyViolationException)
-> Text -> PolicyViolationException
forall a b. (a -> b) -> a -> b
$
                         [Text] -> Text
T.concat [ Text
"Policy disallowed upload of file \""
                                  , Text
fn
                                  , Text
"\" with content-type \""
                                  , Text
ct
                                  , Text
"\"" ] )


------------------------------------------------------------------------------
-- | Contents of form field of type @file@
data FormFile a = FormFile
    { FormFile a -> ByteString
formFileName  :: !ByteString
         -- ^ Name of a field
    , FormFile a -> a
formFileValue :: a
         -- ^ Result of storing file
    } deriving (FormFile a -> FormFile a -> Bool
(FormFile a -> FormFile a -> Bool)
-> (FormFile a -> FormFile a -> Bool) -> Eq (FormFile a)
forall a. Eq a => FormFile a -> FormFile a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormFile a -> FormFile a -> Bool
$c/= :: forall a. Eq a => FormFile a -> FormFile a -> Bool
== :: FormFile a -> FormFile a -> Bool
$c== :: forall a. Eq a => FormFile a -> FormFile a -> Bool
Eq, Eq (FormFile a)
Eq (FormFile a)
-> (FormFile a -> FormFile a -> Ordering)
-> (FormFile a -> FormFile a -> Bool)
-> (FormFile a -> FormFile a -> Bool)
-> (FormFile a -> FormFile a -> Bool)
-> (FormFile a -> FormFile a -> Bool)
-> (FormFile a -> FormFile a -> FormFile a)
-> (FormFile a -> FormFile a -> FormFile a)
-> Ord (FormFile a)
FormFile a -> FormFile a -> Bool
FormFile a -> FormFile a -> Ordering
FormFile a -> FormFile a -> FormFile a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (FormFile a)
forall a. Ord a => FormFile a -> FormFile a -> Bool
forall a. Ord a => FormFile a -> FormFile a -> Ordering
forall a. Ord a => FormFile a -> FormFile a -> FormFile a
min :: FormFile a -> FormFile a -> FormFile a
$cmin :: forall a. Ord a => FormFile a -> FormFile a -> FormFile a
max :: FormFile a -> FormFile a -> FormFile a
$cmax :: forall a. Ord a => FormFile a -> FormFile a -> FormFile a
>= :: FormFile a -> FormFile a -> Bool
$c>= :: forall a. Ord a => FormFile a -> FormFile a -> Bool
> :: FormFile a -> FormFile a -> Bool
$c> :: forall a. Ord a => FormFile a -> FormFile a -> Bool
<= :: FormFile a -> FormFile a -> Bool
$c<= :: forall a. Ord a => FormFile a -> FormFile a -> Bool
< :: FormFile a -> FormFile a -> Bool
$c< :: forall a. Ord a => FormFile a -> FormFile a -> Bool
compare :: FormFile a -> FormFile a -> Ordering
$ccompare :: forall a. Ord a => FormFile a -> FormFile a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (FormFile a)
Ord, Int -> FormFile a -> ShowS
[FormFile a] -> ShowS
FormFile a -> FilePath
(Int -> FormFile a -> ShowS)
-> (FormFile a -> FilePath)
-> ([FormFile a] -> ShowS)
-> Show (FormFile a)
forall a. Show a => Int -> FormFile a -> ShowS
forall a. Show a => [FormFile a] -> ShowS
forall a. Show a => FormFile a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FormFile a] -> ShowS
$cshowList :: forall a. Show a => [FormFile a] -> ShowS
show :: FormFile a -> FilePath
$cshow :: forall a. Show a => FormFile a -> FilePath
showsPrec :: Int -> FormFile a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FormFile a -> ShowS
Show)

data UploadState a = UploadState
     { UploadState a -> Int
numUploadedFiles :: !Int
     , UploadState a -> [FormFile a] -> [FormFile a]
uploadedFiles :: !([FormFile a] -> [FormFile a])
     }

-- | Processes form data and calls provided storage function on
-- file parts.
--
-- You can use this together with 'withTemporaryStore', 'storeAsLazyByteString'
-- or provide your own callback to store uploaded files.
--
-- If you need to process uploaded file mime type or file name, do it in the
-- store callback function.
--
-- See also 'foldMultipart'.
--
-- Example using with small files which can safely be stored in memory.
--
-- @
--
-- import qualified Data.ByteString.Lazy as Lazy
--
-- handleSmallFiles :: MonadSnap m => [(ByteString, ByteString, Lazy.ByteString)]
-- handleSmallFiles = handleFormUploads uploadPolicy filePolicy store
--
--   where
--     uploadPolicy = defaultUploadPolicy
--     filePolicy = setMaximumFileSize (64*1024)
--                  $ setMaximumNumberOfFiles 5
--                    defaultUploadPolicy
--     store partInfo stream = do
--        content <- storeAsLazyByteString partInfo stream
--        let
--          fileName = partFileName partInfo
--          fileMime = partContentType partInfo
--        in (fileName, fileMime, content)
-- @
--
handleFormUploads ::
       (MonadSnap m) =>
       UploadPolicy                   -- ^ general upload policy
    -> FileUploadPolicy               -- ^ Upload policy for files
    -> (PartInfo -> InputStream ByteString -> IO a)
                                      -- ^ A file storage function
    -> m ([FormParam], [FormFile a])
handleFormUploads :: UploadPolicy
-> FileUploadPolicy
-> (PartInfo -> InputStream ByteString -> IO a)
-> m ([FormParam], [FormFile a])
handleFormUploads UploadPolicy
uploadPolicy FileUploadPolicy
filePolicy PartInfo -> InputStream ByteString -> IO a
partHandler = do
    ([FormParam]
params, !UploadState a
st) <- UploadPolicy
-> PartFold (UploadState a)
-> UploadState a
-> m ([FormParam], UploadState a)
forall (m :: * -> *) a.
MonadSnap m =>
UploadPolicy -> PartFold a -> a -> m ([FormParam], a)
foldMultipart UploadPolicy
uploadPolicy PartFold (UploadState a)
go (Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
forall a. Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
UploadState Int
0 [FormFile a] -> [FormFile a]
forall a. a -> a
id)
    ([FormParam], [FormFile a]) -> m ([FormParam], [FormFile a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([FormParam]
params, UploadState a -> [FormFile a] -> [FormFile a]
forall a. UploadState a -> [FormFile a] -> [FormFile a]
uploadedFiles UploadState a
st [])
  where
    go :: PartFold (UploadState a)
go !PartInfo
partInfo InputStream ByteString
stream !UploadState a
st = do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numUploads Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxFiles) IO ()
forall a. IO a
throwTooManyFiles

        case PartInfo -> Maybe ByteString
partFileName PartInfo
partInfo of
          Maybe ByteString
Nothing -> IO (UploadState a)
onEmptyName
          Just ByteString
_ -> IO (UploadState a)
takeIt

      where
        numUploads :: Int
numUploads = UploadState a -> Int
forall a. UploadState a -> Int
numUploadedFiles UploadState a
st
        files :: [FormFile a] -> [FormFile a]
files = UploadState a -> [FormFile a] -> [FormFile a]
forall a. UploadState a -> [FormFile a] -> [FormFile a]
uploadedFiles UploadState a
st
        maxFiles :: Int
maxFiles = FileUploadPolicy -> Int
maxNumberOfFiles FileUploadPolicy
filePolicy
        maxFileSize :: Int64
maxFileSize = FileUploadPolicy -> Int64
maxFileUploadSize FileUploadPolicy
filePolicy
        fnText :: ByteString
fnText = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PartInfo -> Maybe ByteString
partFileName PartInfo
partInfo

        fn :: Text
fn = ByteString -> Text
TE.decodeUtf8 ByteString
fnText

        takeIt :: IO (UploadState a)
takeIt = do
            InputStream ByteString
str' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
maxFileSize InputStream ByteString
stream
            a
r <- PartInfo -> InputStream ByteString -> IO a
partHandler PartInfo
partInfo InputStream ByteString
str' IO a -> (TooManyBytesReadException -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Int64 -> TooManyBytesReadException -> IO a
forall (m :: * -> *) a a.
(MonadBase IO m, Show a) =>
a -> TooManyBytesReadException -> m a
tooMany Int64
maxFileSize
            let f :: FormFile a
f = ByteString -> a -> FormFile a
forall a. ByteString -> a -> FormFile a
FormFile (PartInfo -> ByteString
partFieldName PartInfo
partInfo) a
r
            UploadState a -> IO (UploadState a)
forall (m :: * -> *) a. Monad m => a -> m a
return (UploadState a -> IO (UploadState a))
-> UploadState a -> IO (UploadState a)
forall a b. (a -> b) -> a -> b
$! Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
forall a. Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
UploadState (Int -> Int
forall a. Enum a => a -> a
succ Int
numUploads) ([FormFile a] -> [FormFile a]
files ([FormFile a] -> [FormFile a])
-> ([FormFile a] -> [FormFile a]) -> [FormFile a] -> [FormFile a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FormFile a
f] [FormFile a] -> [FormFile a] -> [FormFile a]
forall a. [a] -> [a] -> [a]
++) )

        skipIt :: Int64 -> IO (UploadState a)
skipIt Int64
maxSize = do
            InputStream ByteString
str' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
maxSize InputStream ByteString
stream
            !()
_ <- InputStream ByteString -> IO ()
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
str' IO () -> (TooManyBytesReadException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Int64 -> TooManyBytesReadException -> IO ()
forall (m :: * -> *) a a.
(MonadBase IO m, Show a) =>
a -> TooManyBytesReadException -> m a
tooMany Int64
maxSize
            UploadState a -> IO (UploadState a)
forall (m :: * -> *) a. Monad m => a -> m a
return (UploadState a -> IO (UploadState a))
-> UploadState a -> IO (UploadState a)
forall a b. (a -> b) -> a -> b
$! Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
forall a. Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
UploadState (Int -> Int
forall a. Enum a => a -> a
succ Int
numUploads) [FormFile a] -> [FormFile a]
files

        onEmptyName :: IO (UploadState a)
onEmptyName = if FileUploadPolicy -> Bool
skipEmptyFileName FileUploadPolicy
filePolicy
                      then Int64 -> IO (UploadState a)
skipIt (FileUploadPolicy -> Int64
maxEmptyFileNameSize FileUploadPolicy
filePolicy)
                      else IO (UploadState a)
takeIt


        throwTooManyFiles :: IO a
throwTooManyFiles = PolicyViolationException -> IO a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (PolicyViolationException -> IO a)
-> (Text -> PolicyViolationException) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PolicyViolationException
PolicyViolationException (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
                            [Text
"number of files exceeded the maximum of "
                            ,FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
maxFiles) ]

        tooMany :: a -> TooManyBytesReadException -> m a
tooMany a
maxSize (TooManyBytesReadException
_ :: TooManyBytesReadException) =
            PolicyViolationException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (PolicyViolationException -> m a)
-> (Text -> PolicyViolationException) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PolicyViolationException
PolicyViolationException (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$
                    [Text] -> Text
T.concat [ Text
"File \""
                             , Text
fn
                             , Text
"\" exceeded maximum allowable size "
                             , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show a
maxSize ]


------------------------------------------------------------------------------
-- | A type alias for a function that will process one of the parts of a
-- @multipart/form-data@ HTTP request body with accumulator.
type PartFold a = PartInfo -> InputStream ByteString -> a -> IO a


------------------------------------------------------------------------------
-- | Given an upload policy and a function to consume uploaded \"parts\",
-- consume a request body uploaded with @Content-type: multipart/form-data@.
--
-- If 'setProcessFormInputs' is 'True', then parts with disposition @form-data@
-- (a form parameter) will be processed and returned as first element of
-- resulting pair. Parts with other disposition will be fed to 'PartFold'
-- handler.
--
-- If 'setProcessFormInputs' is 'False', then parts with any disposition will
-- be fed to 'PartFold' handler and first element of returned pair will be
-- empty. In this case it is important that you limit number of form inputs
-- and sizes of inputs in your 'PartFold' handler to avoid common DOS attacks.
--
-- Note: /THE REQUEST MUST BE CORRECTLY ENCODED/. If the request's
-- @Content-type@ is not \"@multipart/formdata@\", this function skips
-- processing using 'pass'.
--
-- Most users will opt for the higher-level 'handleFileUploads', which writes
-- to temporary files, rather than 'handleMultipart'. This function should be
-- chosen, however, if you need to stream uploaded files directly to your own
-- processing function: e.g. to a database or a remote service via RPC.
--
-- 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.
--
-- /Exceptions/
--
-- If the given 'UploadPolicy' stipulates that you wish form inputs to be
-- processed (using 'setProcessFormInputs'), and a form input exceeds the
-- maximum allowable size or the form exceeds maximum number of inputs, 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'.
--
-- /Since: 1.0.3.0/
foldMultipart ::
       (MonadSnap m) =>
       UploadPolicy        -- ^ global upload policy
    -> PartFold a          -- ^ part processor
    -> a                   -- ^ seed accumulator
    -> m ([FormParam], a)
foldMultipart :: UploadPolicy -> PartFold a -> a -> m ([FormParam], a)
foldMultipart UploadPolicy
uploadPolicy PartFold a
origPartHandler a
zero = do
    Headers
hdrs <- (Request -> Headers) -> m Request -> m Headers
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Headers
forall a. HasHeaders a => a -> Headers
headers m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    let (ByteString
ct, Maybe ByteString
mbBoundary) = Headers -> (ByteString, Maybe ByteString)
getContentType Headers
hdrs

    Int -> IO ()
tickleTimeout <- (((Int -> Int) -> IO ()) -> Int -> IO ())
-> m ((Int -> Int) -> IO ()) -> m (Int -> IO ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int -> Int) -> IO ()) -> (Int -> Int -> Int) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max) m ((Int -> Int) -> IO ())
forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier
    let bumpTimeout :: IO ()
bumpTimeout = Int -> IO ()
tickleTimeout (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ UploadPolicy -> Int
uploadTimeout UploadPolicy
uploadPolicy

    let partHandler :: PartInfo -> InputStream ByteString -> a -> IO (Capture a)
partHandler = if UploadPolicy -> Bool
doProcessFormInputs UploadPolicy
uploadPolicy
                        then Int64
-> PartFold a
-> PartInfo
-> InputStream ByteString
-> a
-> IO (Capture a)
forall a.
Int64
-> PartFold a
-> PartInfo
-> InputStream ByteString
-> a
-> IO (Capture a)
captureVariableOrReadFile
                                 (UploadPolicy -> Int64
getMaximumFormInputSize UploadPolicy
uploadPolicy)
                                 PartFold a
origPartHandler
                        else \PartInfo
x InputStream ByteString
y a
acc -> (a -> Capture a) -> IO a -> IO (Capture a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Capture a
forall a. a -> Capture a
File (IO a -> IO (Capture a)) -> IO a -> IO (Capture a)
forall a b. (a -> b) -> a -> b
$ PartFold a
origPartHandler PartInfo
x InputStream ByteString
y a
acc

    -- not well-formed multipart? bomb out.
    Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString
ct ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"multipart/form-data")

    ByteString
boundary <- m ByteString
-> (ByteString -> m ByteString) -> Maybe ByteString -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BadPartException -> m ByteString
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (BadPartException -> m ByteString)
-> BadPartException -> m ByteString
forall a b. (a -> b) -> a -> b
$ Text -> BadPartException
BadPartException
                       Text
"got multipart/form-data without boundary")
                      ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
                      Maybe ByteString
mbBoundary

    -- RateTooSlowException will be caught and properly dealt with by
    -- runRequestBody
    (InputStream ByteString -> IO ([FormParam], a))
-> m ([FormParam], a)
forall (m :: * -> *) a.
MonadSnap m =>
(InputStream ByteString -> IO a) -> m a
runRequestBody (IO ()
-> ByteString
-> (PartInfo -> InputStream ByteString -> a -> IO (Capture a))
-> InputStream ByteString
-> IO ([FormParam], a)
proc IO ()
bumpTimeout ByteString
boundary PartInfo -> InputStream ByteString -> a -> IO (Capture a)
partHandler)

  where
    --------------------------------------------------------------------------
    uploadRate :: Double
uploadRate  = UploadPolicy -> Double
minimumUploadRate UploadPolicy
uploadPolicy
    uploadSecs :: Int
uploadSecs  = UploadPolicy -> Int
minimumUploadSeconds UploadPolicy
uploadPolicy
    maxFormVars :: Int
maxFormVars = UploadPolicy -> Int
maximumNumberOfFormInputs UploadPolicy
uploadPolicy

    --------------------------------------------------------------------------
    proc :: IO ()
-> ByteString
-> (PartInfo -> InputStream ByteString -> a -> IO (Capture a))
-> InputStream ByteString
-> IO ([FormParam], a)
proc IO ()
bumpTimeout ByteString
boundary PartInfo -> InputStream ByteString -> a -> IO (Capture a)
partHandler =
        IO ()
-> Double
-> Int
-> InputStream ByteString
-> IO (InputStream ByteString)
Streams.throwIfTooSlow IO ()
bumpTimeout Double
uploadRate Int
uploadSecs (InputStream ByteString -> IO (InputStream ByteString))
-> (InputStream ByteString -> IO ([FormParam], a))
-> InputStream ByteString
-> IO ([FormParam], a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
        Int
-> ByteString
-> (PartInfo -> InputStream ByteString -> a -> IO (Capture a))
-> a
-> InputStream ByteString
-> IO ([FormParam], a)
forall a.
Int
-> ByteString
-> (PartInfo -> InputStream ByteString -> a -> IO (Capture a))
-> a
-> InputStream ByteString
-> IO ([FormParam], a)
internalFoldMultipart Int
maxFormVars ByteString
boundary PartInfo -> InputStream ByteString -> a -> IO (Capture a)
partHandler a
zero

------------------------------------------------------------------------------
-- | A type alias for a function that will process one of the parts of a
-- @multipart/form-data@ HTTP request body without usinc accumulator.
type PartProcessor a = PartInfo -> InputStream ByteString -> IO a


------------------------------------------------------------------------------
-- | A variant of 'foldMultipart' accumulating results into a list.
-- Also puts captured 'FormParam's into rqPostParams and rqParams maps.
--
handleMultipart ::
       (MonadSnap m) =>
       UploadPolicy        -- ^ global upload policy
    -> PartProcessor a     -- ^ part processor
    -> m [a]
handleMultipart :: UploadPolicy -> PartProcessor a -> m [a]
handleMultipart UploadPolicy
uploadPolicy PartProcessor a
origPartHandler = do
    ([FormParam]
captures, [a] -> [a]
files) <- UploadPolicy
-> PartFold ([a] -> [a])
-> ([a] -> [a])
-> m ([FormParam], [a] -> [a])
forall (m :: * -> *) a.
MonadSnap m =>
UploadPolicy -> PartFold a -> a -> m ([FormParam], a)
foldMultipart UploadPolicy
uploadPolicy PartFold ([a] -> [a])
forall c.
PartInfo -> InputStream ByteString -> ([a] -> c) -> IO ([a] -> c)
partFold [a] -> [a]
forall a. a -> a
id
    [FormParam] -> m ()
forall (f :: * -> *). MonadSnap f => [FormParam] -> f ()
procCaptures [FormParam]
captures
    [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$! [a] -> [a]
files []

  where
    partFold :: PartInfo -> InputStream ByteString -> ([a] -> c) -> IO ([a] -> c)
partFold PartInfo
info InputStream ByteString
input [a] -> c
acc = do
      a
x <- PartProcessor a
origPartHandler PartInfo
info InputStream ByteString
input
      ([a] -> c) -> IO ([a] -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a] -> c) -> IO ([a] -> c)) -> ([a] -> c) -> IO ([a] -> c)
forall a b. (a -> b) -> a -> b
$ [a] -> c
acc ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a
x][a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++)
    --------------------------------------------------------------------------
    procCaptures :: [FormParam] -> f ()
procCaptures []          = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    procCaptures [FormParam]
params = do
        Request
rq <- f Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
        Request -> f ()
forall (m :: * -> *). MonadSnap m => Request -> m ()
putRequest (Request -> f ()) -> Request -> f ()
forall a b. (a -> b) -> a -> b
$ (Params -> Params) -> Request -> Request
modifyParams (\Params
m -> (FormParam -> Params -> Params) -> Params -> [FormParam] -> Params
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FormParam -> Params -> Params
forall k a. Ord k => (k, a) -> Map k [a] -> Map k [a]
ins Params
m [FormParam]
params) Request
rq

    --------------------------------------------------------------------------
    ins :: (k, a) -> Map k [a] -> Map k [a]
ins (!k
k, !a
v) = ([a] -> [a] -> [a]) -> k -> [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\[a]
_ [a]
ex -> (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ex)) k
k [a
v]
         -- prepend value if key exists, since we are folding from right

    --------------------------------------------------------------------------
    modifyParams :: (Params -> Params) -> Request -> Request
modifyParams Params -> Params
f Request
r = Request
r { rqPostParams :: Params
rqPostParams = Params -> Params
f (Params -> Params) -> Params -> Params
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqPostParams Request
r
                         , rqParams :: Params
rqParams     = Params -> Params
f (Params -> Params) -> Params -> Params
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqParams Request
r
                         }

------------------------------------------------------------------------------
-- | Represents the disposition type specified via the @Content-Disposition@
-- header field. See <https://www.ietf.org/rfc/rfc1806.txt RFC 1806>.
data PartDisposition =
    DispositionAttachment       -- ^ @Content-Disposition: attachment@.
  | DispositionFile             -- ^ @Content-Disposition: file@.
  | DispositionFormData         -- ^ @Content-Disposition: form-data@.
  | DispositionOther ByteString -- ^ Any other value.
  deriving (PartDisposition -> PartDisposition -> Bool
(PartDisposition -> PartDisposition -> Bool)
-> (PartDisposition -> PartDisposition -> Bool)
-> Eq PartDisposition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PartDisposition -> PartDisposition -> Bool
$c/= :: PartDisposition -> PartDisposition -> Bool
== :: PartDisposition -> PartDisposition -> Bool
$c== :: PartDisposition -> PartDisposition -> Bool
Eq, Int -> PartDisposition -> ShowS
[PartDisposition] -> ShowS
PartDisposition -> FilePath
(Int -> PartDisposition -> ShowS)
-> (PartDisposition -> FilePath)
-> ([PartDisposition] -> ShowS)
-> Show PartDisposition
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PartDisposition] -> ShowS
$cshowList :: [PartDisposition] -> ShowS
show :: PartDisposition -> FilePath
$cshow :: PartDisposition -> FilePath
showsPrec :: Int -> PartDisposition -> ShowS
$cshowsPrec :: Int -> PartDisposition -> ShowS
Show)


------------------------------------------------------------------------------
-- | 'PartInfo' contains information about a \"part\" in a request uploaded
-- with @Content-type: multipart/form-data@.
data PartInfo =
  PartInfo
  { PartInfo -> ByteString
partFieldName   :: !ByteString
    -- ^ Field name associated with this part (i.e., the name specified with
    -- @\<input name=\"partFieldName\" ...@).
  , PartInfo -> Maybe ByteString
partFileName    :: !(Maybe ByteString)
    -- ^ Name of the uploaded file.
  , PartInfo -> ByteString
partContentType :: !ByteString
    -- ^ Content type of this part.
  , PartInfo -> PartDisposition
partDisposition :: !PartDisposition
    -- ^ Disposition type of this part. See 'PartDisposition'.
  , PartInfo -> Headers
partHeaders     :: !Headers
    -- ^ Remaining headers associated with this part.
  }
  deriving (Int -> PartInfo -> ShowS
[PartInfo] -> ShowS
PartInfo -> FilePath
(Int -> PartInfo -> ShowS)
-> (PartInfo -> FilePath) -> ([PartInfo] -> ShowS) -> Show PartInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PartInfo] -> ShowS
$cshowList :: [PartInfo] -> ShowS
show :: PartInfo -> FilePath
$cshow :: PartInfo -> FilePath
showsPrec :: Int -> PartInfo -> ShowS
$cshowsPrec :: Int -> PartInfo -> ShowS
Show)


------------------------------------------------------------------------------
toPartDisposition :: ByteString -> PartDisposition
toPartDisposition :: ByteString -> PartDisposition
toPartDisposition ByteString
s | ByteString
s ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"attachment" = PartDisposition
DispositionAttachment
                    | ByteString
s ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"file"       = PartDisposition
DispositionFile
                    | ByteString
s ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"form-data"  = PartDisposition
DispositionFormData
                    | Bool
otherwise         = ByteString -> PartDisposition
DispositionOther ByteString
s


------------------------------------------------------------------------------
-- | 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 = forall e . (ExceptionWithReason e, Show e) =>
                           WrappedFileUploadException e
  deriving (Typeable)


------------------------------------------------------------------------------
class Exception e => ExceptionWithReason e where
    exceptionReason :: e -> Text


------------------------------------------------------------------------------
instance Show FileUploadException where
    show :: FileUploadException -> FilePath
show (WrappedFileUploadException e
e) = e -> FilePath
forall a. Show a => a -> FilePath
show e
e


------------------------------------------------------------------------------
instance Exception FileUploadException


------------------------------------------------------------------------------
-- | Human-readable error message corresponding to the 'FileUploadException'.
fileUploadExceptionReason :: FileUploadException -> Text
fileUploadExceptionReason :: FileUploadException -> Text
fileUploadExceptionReason (WrappedFileUploadException e
e) = e -> Text
forall e. ExceptionWithReason e => e -> Text
exceptionReason e
e


------------------------------------------------------------------------------
uploadExceptionToException :: ExceptionWithReason e => e -> SomeException
uploadExceptionToException :: e -> SomeException
uploadExceptionToException = FileUploadException -> SomeException
forall e. Exception e => e -> SomeException
toException (FileUploadException -> SomeException)
-> (e -> FileUploadException) -> e -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FileUploadException
forall e.
(ExceptionWithReason e, Show e) =>
e -> FileUploadException
WrappedFileUploadException


------------------------------------------------------------------------------
uploadExceptionFromException :: ExceptionWithReason e => SomeException -> Maybe e
uploadExceptionFromException :: SomeException -> Maybe e
uploadExceptionFromException SomeException
x = do
    WrappedFileUploadException e
e <- SomeException -> Maybe FileUploadException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
    e -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e


------------------------------------------------------------------------------
-- | Thrown when a part is invalid in some way (e.g. the headers are too large).
data BadPartException = BadPartException {
  -- | Human-readable error message corresponding to the 'BadPartException'.
  BadPartException -> Text
badPartExceptionReason :: Text
  }
  deriving (Typeable)

instance Exception BadPartException where
    toException :: BadPartException -> SomeException
toException = BadPartException -> SomeException
forall e. ExceptionWithReason e => e -> SomeException
uploadExceptionToException
    fromException :: SomeException -> Maybe BadPartException
fromException = SomeException -> Maybe BadPartException
forall e. ExceptionWithReason e => SomeException -> Maybe e
uploadExceptionFromException

instance ExceptionWithReason BadPartException where
    exceptionReason :: BadPartException -> Text
exceptionReason (BadPartException Text
e) = [Text] -> Text
T.concat [Text
"Bad part: ", Text
e]

instance Show BadPartException where
  show :: BadPartException -> FilePath
show = Text -> FilePath
T.unpack (Text -> FilePath)
-> (BadPartException -> Text) -> BadPartException -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BadPartException -> Text
forall e. ExceptionWithReason e => e -> Text
exceptionReason


------------------------------------------------------------------------------
-- | Thrown when an 'UploadPolicy' or 'PartUploadPolicy' is violated.
data PolicyViolationException = PolicyViolationException {
      -- | Human-readable error message corresponding to the
      -- 'PolicyViolationException'.
      PolicyViolationException -> Text
policyViolationExceptionReason :: Text
    } deriving (Typeable)

instance Exception PolicyViolationException where
    toException :: PolicyViolationException -> SomeException
toException e :: PolicyViolationException
e@(PolicyViolationException Text
_) =
        PolicyViolationException -> SomeException
forall e. ExceptionWithReason e => e -> SomeException
uploadExceptionToException PolicyViolationException
e
    fromException :: SomeException -> Maybe PolicyViolationException
fromException = SomeException -> Maybe PolicyViolationException
forall e. ExceptionWithReason e => SomeException -> Maybe e
uploadExceptionFromException

instance ExceptionWithReason PolicyViolationException where
    exceptionReason :: PolicyViolationException -> Text
exceptionReason (PolicyViolationException Text
r) =
        [Text] -> Text
T.concat [Text
"File upload policy violation: ", Text
r]

instance Show PolicyViolationException where
  show :: PolicyViolationException -> FilePath
show (PolicyViolationException Text
s) = FilePath
"File upload policy violation: "
                                            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
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 {
      UploadPolicy -> Bool
processFormInputs         :: Bool
    , UploadPolicy -> Int64
maximumFormInputSize      :: Int64
    , UploadPolicy -> Int
maximumNumberOfFormInputs :: Int
    , UploadPolicy -> Double
minimumUploadRate         :: Double
    , UploadPolicy -> Int
minimumUploadSeconds      :: Int
    , UploadPolicy -> Int
uploadTimeout             :: Int
}


------------------------------------------------------------------------------
-- | 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
defaultUploadPolicy = Bool -> Int64 -> Int -> Double -> Int -> Int -> UploadPolicy
UploadPolicy Bool
True Int64
maxSize Int
maxNum Double
minRate Int
minSeconds Int
tout
  where
    maxSize :: Int64
maxSize    = Int64
2Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
17::Int)
    maxNum :: Int
maxNum     = Int
10
    minRate :: Double
minRate    = Double
1000
    minSeconds :: Int
minSeconds = Int
10
    tout :: Int
tout       = Int
20


------------------------------------------------------------------------------
-- | Does this upload policy stipulate that we want to treat parts without
-- filenames as form input?
doProcessFormInputs :: UploadPolicy -> Bool
doProcessFormInputs :: UploadPolicy -> Bool
doProcessFormInputs = UploadPolicy -> Bool
processFormInputs


------------------------------------------------------------------------------
-- | Set the upload policy for treating parts without filenames as form input.
setProcessFormInputs :: Bool -> UploadPolicy -> UploadPolicy
setProcessFormInputs :: Bool -> UploadPolicy -> UploadPolicy
setProcessFormInputs Bool
b UploadPolicy
u = UploadPolicy
u { processFormInputs :: Bool
processFormInputs = Bool
b }


------------------------------------------------------------------------------
-- | Get the maximum size of a form input which will be read into our
--   'rqParams' map.
getMaximumFormInputSize :: UploadPolicy -> Int64
getMaximumFormInputSize :: UploadPolicy -> Int64
getMaximumFormInputSize = UploadPolicy -> Int64
maximumFormInputSize


------------------------------------------------------------------------------
-- | Set the maximum size of a form input which will be read into our
--   'rqParams' map.
setMaximumFormInputSize :: Int64 -> UploadPolicy -> UploadPolicy
setMaximumFormInputSize :: Int64 -> UploadPolicy -> UploadPolicy
setMaximumFormInputSize Int64
s UploadPolicy
u = UploadPolicy
u { maximumFormInputSize :: Int64
maximumFormInputSize = Int64
s }


------------------------------------------------------------------------------
-- | Get the maximum size of a form input which will be read into our
--   'rqParams' map.
getMaximumNumberOfFormInputs :: UploadPolicy -> Int
getMaximumNumberOfFormInputs :: UploadPolicy -> Int
getMaximumNumberOfFormInputs = UploadPolicy -> Int
maximumNumberOfFormInputs


------------------------------------------------------------------------------
-- | Set the maximum size of a form input which will be read into our
--   'rqParams' map.
setMaximumNumberOfFormInputs :: Int -> UploadPolicy -> UploadPolicy
setMaximumNumberOfFormInputs :: Int -> UploadPolicy -> UploadPolicy
setMaximumNumberOfFormInputs Int
s UploadPolicy
u = UploadPolicy
u { maximumNumberOfFormInputs :: Int
maximumNumberOfFormInputs = Int
s }


------------------------------------------------------------------------------
-- | Get the minimum rate (in /bytes\/second/) a client must maintain before
--   we kill the connection.
getMinimumUploadRate :: UploadPolicy -> Double
getMinimumUploadRate :: UploadPolicy -> Double
getMinimumUploadRate = UploadPolicy -> Double
minimumUploadRate


------------------------------------------------------------------------------
-- | Set the minimum rate (in /bytes\/second/) a client must maintain before
--   we kill the connection.
setMinimumUploadRate :: Double -> UploadPolicy -> UploadPolicy
setMinimumUploadRate :: Double -> UploadPolicy -> UploadPolicy
setMinimumUploadRate Double
s UploadPolicy
u = UploadPolicy
u { minimumUploadRate :: Double
minimumUploadRate = Double
s }


------------------------------------------------------------------------------
-- | Get the amount of time which must elapse before we begin enforcing the
--   upload rate minimum
getMinimumUploadSeconds :: UploadPolicy -> Int
getMinimumUploadSeconds :: UploadPolicy -> Int
getMinimumUploadSeconds = UploadPolicy -> Int
minimumUploadSeconds


------------------------------------------------------------------------------
-- | Set the amount of time which must elapse before we begin enforcing the
--   upload rate minimum
setMinimumUploadSeconds :: Int -> UploadPolicy -> UploadPolicy
setMinimumUploadSeconds :: Int -> UploadPolicy -> UploadPolicy
setMinimumUploadSeconds Int
s UploadPolicy
u = UploadPolicy
u { minimumUploadSeconds :: Int
minimumUploadSeconds = Int
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 :: UploadPolicy -> Int
getUploadTimeout = UploadPolicy -> Int
uploadTimeout


------------------------------------------------------------------------------
-- | Set the upload timeout.
setUploadTimeout :: Int -> UploadPolicy -> UploadPolicy
setUploadTimeout :: Int -> UploadPolicy -> UploadPolicy
setUploadTimeout Int
s UploadPolicy
u = UploadPolicy
u { uploadTimeout :: Int
uploadTimeout = Int
s }


------------------------------------------------------------------------------

-- | File upload policy, if any policy is violated then
-- 'PolicyViolationException' is thrown
data FileUploadPolicy = FileUploadPolicy
    { FileUploadPolicy -> Int64
maxFileUploadSize    :: !Int64
    , FileUploadPolicy -> Int
maxNumberOfFiles     :: !Int
    , FileUploadPolicy -> Bool
skipEmptyFileName    :: !Bool
    , FileUploadPolicy -> Int64
maxEmptyFileNameSize :: !Int64
    }

-- | A default 'FileUploadPolicy'
--
--   [@maximum file size@]             1MB
--
--   [@maximum number of files@]       10
--
--   [@skip files without name@]       yes
--
--   [@maximum size of skipped file@]  0
--
--
defaultFileUploadPolicy :: FileUploadPolicy
defaultFileUploadPolicy :: FileUploadPolicy
defaultFileUploadPolicy = Int64 -> Int -> Bool -> Int64 -> FileUploadPolicy
FileUploadPolicy Int64
maxFileSize Int
maxFiles
                                           Bool
skipEmptyName Int64
maxEmptySize
  where
    maxFileSize :: Int64
maxFileSize = Int64
1048576 -- 1MB
    maxFiles :: Int
maxFiles    = Int
10
    skipEmptyName :: Bool
skipEmptyName = Bool
True
    maxEmptySize :: Int64
maxEmptySize = Int64
0

-- | Maximum size of single uploaded file.
setMaximumFileSize :: Int64 -> FileUploadPolicy -> FileUploadPolicy
setMaximumFileSize :: Int64 -> FileUploadPolicy -> FileUploadPolicy
setMaximumFileSize Int64
maxSize FileUploadPolicy
s =
    FileUploadPolicy
s { maxFileUploadSize :: Int64
maxFileUploadSize = Int64
maxSize }

-- | Maximum number of uploaded files.
setMaximumNumberOfFiles :: Int -> FileUploadPolicy -> FileUploadPolicy
setMaximumNumberOfFiles :: Int -> FileUploadPolicy -> FileUploadPolicy
setMaximumNumberOfFiles Int
maxFiles FileUploadPolicy
s =
    FileUploadPolicy
s { maxNumberOfFiles :: Int
maxNumberOfFiles = Int
maxFiles }

-- | Skip files with empty file names.
--
-- If set, parts without filenames will not be fed to storage function.
--
-- HTML5 form data encoding standard states that form input fields of type
-- file, without value set, are encoded same way as if file with empty body,
-- empty file name, and type @application/octet-stream@ was set as value.
--
-- You most likely want to use this with zero bytes allowed to avoid storing
-- such fields (see 'setMaximumSkippedFileSize').
--
-- By default files without names are skipped.
--
-- /Since: 1.0.3.0/
setSkipFilesWithoutNames :: Bool -> FileUploadPolicy -> FileUploadPolicy
setSkipFilesWithoutNames :: Bool -> FileUploadPolicy -> FileUploadPolicy
setSkipFilesWithoutNames Bool
shouldSkip FileUploadPolicy
s =
    FileUploadPolicy
s { skipEmptyFileName :: Bool
skipEmptyFileName = Bool
shouldSkip }

-- | Maximum size of file without name which can be skipped.
--
-- Ignored if 'setSkipFilesWithoutNames' is @False@.
--
-- If skipped file is larger than this setting then 'FileUploadException'
-- is thrown.
--
-- By default maximum file size is 0.
--
-- /Since: 1.0.3.0/
setMaximumSkippedFileSize :: Int64 -> FileUploadPolicy -> FileUploadPolicy
setMaximumSkippedFileSize :: Int64 -> FileUploadPolicy -> FileUploadPolicy
setMaximumSkippedFileSize Int64
maxSize FileUploadPolicy
s =
    FileUploadPolicy
s { maxEmptyFileNameSize :: Int64
maxEmptyFileNameSize = Int64
maxSize }


------------------------------------------------------------------------------
-- | 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 (Maybe Int64)


------------------------------------------------------------------------------
-- | Disallows the file to be uploaded.
disallow :: PartUploadPolicy
disallow :: PartUploadPolicy
disallow = Maybe Int64 -> PartUploadPolicy
PartUploadPolicy Maybe Int64
forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | Allows the file to be uploaded, with maximum size /n/ in bytes.
allowWithMaximumSize :: Int64 -> PartUploadPolicy
allowWithMaximumSize :: Int64 -> PartUploadPolicy
allowWithMaximumSize = Maybe Int64 -> PartUploadPolicy
PartUploadPolicy (Maybe Int64 -> PartUploadPolicy)
-> (Int64 -> Maybe Int64) -> Int64 -> PartUploadPolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Maybe Int64
forall a. a -> Maybe a
Just


------------------------------------------------------------------------------
-- | Stores file body in memory as Lazy ByteString.
storeAsLazyByteString :: InputStream ByteString -> IO LB.ByteString
storeAsLazyByteString :: InputStream ByteString -> IO ByteString
storeAsLazyByteString !InputStream ByteString
str = do
   ByteString -> ByteString
f <- ((ByteString -> ByteString)
 -> ByteString -> ByteString -> ByteString)
-> (ByteString -> ByteString)
-> InputStream ByteString
-> IO (ByteString -> ByteString)
forall s a. (s -> a -> s) -> s -> InputStream a -> IO s
Streams.fold (\ByteString -> ByteString
f ByteString
c -> ByteString -> ByteString
f (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
LB.chunk ByteString
c) ByteString -> ByteString
forall a. a -> a
id InputStream ByteString
str
   ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString
f ByteString
LB.Empty


------------------------------------------------------------------------------
-- | Store files in a temporary directory, and clean up on function exit.
--
-- Files are safe to move until function exists.
--
-- If asynchronous exception is thrown during cleanup, temporary files may
-- remain.
--
-- @
-- uploadsHandler = withTemporaryStore "/var/tmp" "upload-" $ \store -> do
--     (inputs, files) <- handleFormUploads defaultUploadpolicy
--                                          defaultFileUploadPolicy
--                                          (const store)
--     saveFiles files
--
-- @
--
withTemporaryStore ::
    MonadSnap m
    => FilePath -- ^ temporary directory
    -> String   -- ^ file name pattern
    -> ((InputStream ByteString -> IO FilePath) -> m a)
      -- ^ Action taking store function
    -> m a
withTemporaryStore :: FilePath
-> FilePath
-> ((InputStream ByteString -> IO FilePath) -> m a)
-> m a
withTemporaryStore FilePath
tempdir FilePath
pat (InputStream ByteString -> IO FilePath) -> m a
act = do
    IORef [FilePath]
ioref <- IO (IORef [FilePath]) -> m (IORef [FilePath])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [FilePath]) -> m (IORef [FilePath]))
-> IO (IORef [FilePath]) -> m (IORef [FilePath])
forall a b. (a -> b) -> a -> b
$ [FilePath] -> IO (IORef [FilePath])
forall a. a -> IO (IORef a)
IORef.newIORef []
    let
      modifyIORef' :: IORef a -> (a -> a) -> IO ()
modifyIORef' IORef a
ref a -> a
f = do -- ghc 7.4 does not have modifyIORef'
          a
x <- IORef a -> IO a
forall a. IORef a -> IO a
IORef.readIORef IORef a
ref
          let x' :: a
x' = a -> a
f a
x
          a
x' a -> IO () -> IO ()
`seq` IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef a
ref a
x'

      go :: InputStream ByteString -> IO FilePath
go InputStream ByteString
input = do
          (FilePath
fn, Handle
h) <- FilePath -> FilePath -> IO (FilePath, Handle)
openBinaryTempFile FilePath
tempdir FilePath
pat
          IORef [FilePath] -> ([FilePath] -> [FilePath]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [FilePath]
ioref (FilePath
fnFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
          Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering
          OutputStream ByteString
output <- Handle -> IO (OutputStream ByteString)
Streams.handleToOutputStream Handle
h
          InputStream ByteString -> OutputStream ByteString -> IO ()
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream ByteString
input OutputStream ByteString
output
          Handle -> IO ()
hClose Handle
h
          FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
fn

      cleanup :: m ()
cleanup = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          [FilePath]
files <- IORef [FilePath] -> IO [FilePath]
forall a. IORef a -> IO a
IORef.readIORef IORef [FilePath]
ioref
          [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fn ->
             FilePath -> IO ()
removeFile FilePath
fn IO () -> (IOError -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IOError -> IO ()
forall (f :: * -> *). MonadBase IO f => IOError -> f ()
handleExists
      handleExists :: IOError -> f ()
handleExists IOError
e = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOError -> Bool
isDoesNotExistError IOError
e) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ IOError -> f ()
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO IOError
e

    (InputStream ByteString -> IO FilePath) -> m a
act InputStream ByteString -> IO FilePath
go m a -> m () -> m a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`finally` m ()
cleanup


------------------------------------------------------------------------------
-- private exports follow. FIXME: organize
------------------------------------------------------------------------------

------------------------------------------------------------------------------
captureVariableOrReadFile ::
       Int64                                   -- ^ maximum size of form input
    -> PartFold a                              -- ^ file reading code
    -> PartInfo -> InputStream ByteString
    -> a
    -> IO (Capture a)
captureVariableOrReadFile :: Int64
-> PartFold a
-> PartInfo
-> InputStream ByteString
-> a
-> IO (Capture a)
captureVariableOrReadFile Int64
maxSize PartFold a
fileHandler PartInfo
partInfo InputStream ByteString
stream a
acc =
    if Bool
isFile
      then (a -> Capture a) -> IO a -> IO (Capture a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Capture a
forall a. a -> Capture a
File (IO a -> IO (Capture a)) -> IO a -> IO (Capture a)
forall a b. (a -> b) -> a -> b
$ PartFold a
fileHandler PartInfo
partInfo InputStream ByteString
stream a
acc
      else IO (Capture a)
forall a. IO (Capture a)
variable IO (Capture a)
-> (TooManyBytesReadException -> IO (Capture a)) -> IO (Capture a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` TooManyBytesReadException -> IO (Capture a)
forall (m :: * -> *) a.
MonadBase IO m =>
TooManyBytesReadException -> m a
handler

  where
    isFile :: Bool
isFile = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (PartInfo -> Maybe ByteString
partFileName PartInfo
partInfo) Bool -> Bool -> Bool
||
             PartInfo -> PartDisposition
partDisposition PartInfo
partInfo PartDisposition -> PartDisposition -> Bool
forall a. Eq a => a -> a -> Bool
== PartDisposition
DispositionFile

    variable :: IO (Capture a)
variable = do
        !ByteString
x <- ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ByteString] -> ByteString
S.concat (IO [ByteString] -> IO ByteString)
-> IO [ByteString] -> IO ByteString
forall a b. (a -> b) -> a -> b
$
             Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
maxSize InputStream ByteString
stream IO (InputStream ByteString)
-> (InputStream ByteString -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList
        Capture a -> IO (Capture a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Capture a -> IO (Capture a)) -> Capture a -> IO (Capture a)
forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString -> Capture a
forall a. ByteString -> ByteString -> Capture a
Capture ByteString
fieldName ByteString
x

    fieldName :: ByteString
fieldName = PartInfo -> ByteString
partFieldName PartInfo
partInfo

    handler :: TooManyBytesReadException -> m a
handler (TooManyBytesReadException
_ :: TooManyBytesReadException) =
        PolicyViolationException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (PolicyViolationException -> m a)
-> PolicyViolationException -> m a
forall a b. (a -> b) -> a -> b
$ Text -> PolicyViolationException
PolicyViolationException (Text -> PolicyViolationException)
-> Text -> PolicyViolationException
forall a b. (a -> b) -> a -> b
$
                [Text] -> Text
T.concat [ Text
"form input '"
                         , ByteString -> Text
TE.decodeUtf8 ByteString
fieldName
                         , Text
"' exceeded maximum permissible size ("
                         , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> FilePath
forall a. Show a => a -> FilePath
show Int64
maxSize
                         , Text
" bytes)" ]


------------------------------------------------------------------------------
data Capture a = Capture !ByteString !ByteString
               | File a


------------------------------------------------------------------------------
fileReader :: FilePath
           -> (PartInfo -> Either PolicyViolationException FilePath -> IO a)
           -> PartProcessor a
fileReader :: FilePath
-> (PartInfo -> Either PolicyViolationException FilePath -> IO a)
-> PartProcessor a
fileReader FilePath
tmpdir PartInfo -> Either PolicyViolationException FilePath -> IO a
partProc PartInfo
partInfo InputStream ByteString
input =
    FilePath -> FilePath -> ((FilePath, Handle) -> IO a) -> IO a
forall a.
FilePath -> FilePath -> ((FilePath, Handle) -> IO a) -> IO a
withTempFile FilePath
tmpdir FilePath
"snap-upload-" (((FilePath, Handle) -> IO a) -> IO a)
-> ((FilePath, Handle) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(FilePath
fn, Handle
h) -> do
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering
        OutputStream ByteString
output <- Handle -> IO (OutputStream ByteString)
Streams.handleToOutputStream Handle
h
        InputStream ByteString -> OutputStream ByteString -> IO ()
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream ByteString
input OutputStream ByteString
output
        Handle -> IO ()
hClose Handle
h
        PartInfo -> Either PolicyViolationException FilePath -> IO a
partProc PartInfo
partInfo (Either PolicyViolationException FilePath -> IO a)
-> Either PolicyViolationException FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> Either PolicyViolationException FilePath
forall a b. b -> Either a b
Right FilePath
fn


------------------------------------------------------------------------------
data MultipartState a = MultipartState
  { MultipartState a -> Int
numFormVars       :: {-# UNPACK #-} !Int
  , MultipartState a -> Int
numFormFiles      :: {-# UNPACK #-} !Int
  , MultipartState a -> [FormParam] -> [FormParam]
capturedFields    :: !([FormParam] -> [FormParam])
  , MultipartState a -> a
accumulator       :: !a
  }

------------------------------------------------------------------------------
-- | A form parameter name-value pair
type FormParam = (ByteString, ByteString)

------------------------------------------------------------------------------
addCapture :: ByteString -> ByteString -> MultipartState a -> MultipartState a
addCapture :: ByteString -> ByteString -> MultipartState a -> MultipartState a
addCapture !ByteString
k !ByteString
v !MultipartState a
ms =
  let !kv :: FormParam
kv = (ByteString
k,ByteString
v)
      f :: [FormParam] -> [FormParam]
f = MultipartState a -> [FormParam] -> [FormParam]
forall a. MultipartState a -> [FormParam] -> [FormParam]
capturedFields MultipartState a
ms ([FormParam] -> [FormParam])
-> ([FormParam] -> [FormParam]) -> [FormParam] -> [FormParam]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FormParam
kv][FormParam] -> [FormParam] -> [FormParam]
forall a. [a] -> [a] -> [a]
++)
      !ms' :: MultipartState a
ms' = MultipartState a
ms { capturedFields :: [FormParam] -> [FormParam]
capturedFields = [FormParam] -> [FormParam]
f
                , numFormVars :: Int
numFormVars = Int -> Int
forall a. Enum a => a -> a
succ (MultipartState a -> Int
forall a. MultipartState a -> Int
numFormVars MultipartState a
ms) }
  in MultipartState a
ms'


------------------------------------------------------------------------------
internalFoldMultipart ::
       Int           -- ^ max num fields
    -> ByteString                                     -- ^ boundary value
    -> (PartInfo -> InputStream ByteString -> a -> IO (Capture a))  -- ^ part processor
    -> a
    -> InputStream ByteString
    -> IO ([FormParam], a)
internalFoldMultipart :: Int
-> ByteString
-> (PartInfo -> InputStream ByteString -> a -> IO (Capture a))
-> a
-> InputStream ByteString
-> IO ([FormParam], a)
internalFoldMultipart !Int
maxFormVars !ByteString
boundary PartInfo -> InputStream ByteString -> a -> IO (Capture a)
clientHandler !a
zeroAcc !InputStream ByteString
stream = IO ([FormParam], a)
go
  where
    --------------------------------------------------------------------------
    initialState :: MultipartState a
initialState = Int -> Int -> ([FormParam] -> [FormParam]) -> a -> MultipartState a
forall a.
Int -> Int -> ([FormParam] -> [FormParam]) -> a -> MultipartState a
MultipartState Int
0 Int
0 [FormParam] -> [FormParam]
forall a. a -> a
id a
zeroAcc

    --------------------------------------------------------------------------
    go :: IO ([FormParam], a)
go = do
        -- swallow the first boundary
        ByteString
_        <- Parser ByteString -> InputStream ByteString -> IO ByteString
forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream (ByteString -> Parser ByteString
parseFirstBoundary ByteString
boundary) InputStream ByteString
stream
        InputStream MatchInfo
bmstream <- ByteString -> InputStream ByteString -> IO (InputStream MatchInfo)
search (ByteString -> ByteString
fullBoundary ByteString
boundary) InputStream ByteString
stream
        MultipartState a
ms <- (InputStream ByteString
 -> MultipartState a -> IO (MultipartState a))
-> InputStream MatchInfo
-> MultipartState a
-> IO (MultipartState a)
forall a.
(InputStream ByteString
 -> MultipartState a -> IO (MultipartState a))
-> InputStream MatchInfo
-> MultipartState a
-> IO (MultipartState a)
foldParts InputStream ByteString -> MultipartState a -> IO (MultipartState a)
goPart InputStream MatchInfo
bmstream MultipartState a
initialState
        ([FormParam], a) -> IO ([FormParam], a)
forall (m :: * -> *) a. Monad m => a -> m a
return (([FormParam], a) -> IO ([FormParam], a))
-> ([FormParam], a) -> IO ([FormParam], a)
forall a b. (a -> b) -> a -> b
$ (MultipartState a -> [FormParam] -> [FormParam]
forall a. MultipartState a -> [FormParam] -> [FormParam]
capturedFields MultipartState a
ms [], MultipartState a -> a
forall a. MultipartState a -> a
accumulator MultipartState a
ms)

    --------------------------------------------------------------------------
    pBoundary :: ByteString -> Parser ByteString
pBoundary !ByteString
b = Parser ByteString -> Parser ByteString
forall i a. Parser i a -> Parser i a
Atto.try (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ do
      ByteString
_ <- ByteString -> Parser ByteString
string ByteString
"--"
      ByteString -> Parser ByteString
string ByteString
b

    --------------------------------------------------------------------------
    fullBoundary :: ByteString -> ByteString
fullBoundary !ByteString
b       = [ByteString] -> ByteString
S.concat [ByteString
"\r\n", ByteString
"--", ByteString
b]
    pLine :: Parser ByteString
pLine                 = (Char -> Bool) -> Parser ByteString
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Bool
isEndOfLine (Word8 -> Bool) -> (Char -> Word8) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Word8
c2w) Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString
eol
    parseFirstBoundary :: ByteString -> Parser ByteString
parseFirstBoundary !ByteString
b = ByteString -> Parser ByteString
pBoundary ByteString
b Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ByteString
pLine Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Parser ByteString
parseFirstBoundary ByteString
b)


    --------------------------------------------------------------------------
    takeHeaders :: InputStream ByteString -> IO Headers
takeHeaders !InputStream ByteString
str = IO Headers
hdrs IO Headers
-> (TooManyBytesReadException -> IO Headers) -> IO Headers
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` TooManyBytesReadException -> IO Headers
forall (m :: * -> *) a.
MonadBase IO m =>
TooManyBytesReadException -> m a
handler
      where
        hdrs :: IO Headers
hdrs = do
            InputStream ByteString
str' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
mAX_HDRS_SIZE InputStream ByteString
str
            ([FormParam] -> Headers) -> IO [FormParam] -> IO Headers
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [FormParam] -> Headers
toHeaders (IO [FormParam] -> IO Headers) -> IO [FormParam] -> IO Headers
forall a b. (a -> b) -> a -> b
$ Parser [FormParam] -> InputStream ByteString -> IO [FormParam]
forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream Parser [FormParam]
pHeadersWithSeparator InputStream ByteString
str'

        handler :: TooManyBytesReadException -> m a
handler (TooManyBytesReadException
_ :: TooManyBytesReadException) =
            BadPartException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (BadPartException -> m a) -> BadPartException -> m a
forall a b. (a -> b) -> a -> b
$ Text -> BadPartException
BadPartException Text
"headers exceeded maximum size"

    --------------------------------------------------------------------------
    goPart :: InputStream ByteString -> MultipartState a -> IO (MultipartState a)
goPart !InputStream ByteString
str !MultipartState a
state = do
        Headers
hdrs <- InputStream ByteString -> IO Headers
takeHeaders InputStream ByteString
str

        -- are we using mixed?
        let (ByteString
contentType, Maybe ByteString
mboundary) = Headers -> (ByteString, Maybe ByteString)
getContentType Headers
hdrs
        let (ByteString
fieldName, Maybe ByteString
fileName, PartDisposition
disposition) = Headers -> (ByteString, Maybe ByteString, PartDisposition)
getFieldHeaderInfo Headers
hdrs

        if ByteString
contentType ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"multipart/mixed"
          then IO (MultipartState a)
-> (ByteString -> IO (MultipartState a))
-> Maybe ByteString
-> IO (MultipartState a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BadPartException -> IO (MultipartState a)
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (BadPartException -> IO (MultipartState a))
-> BadPartException -> IO (MultipartState a)
forall a b. (a -> b) -> a -> b
$ Text -> BadPartException
BadPartException (Text -> BadPartException) -> Text -> BadPartException
forall a b. (a -> b) -> a -> b
$
                      Text
"got multipart/mixed without boundary")
                     (ByteString
-> InputStream ByteString
-> MultipartState a
-> ByteString
-> IO (MultipartState a)
processMixed ByteString
fieldName InputStream ByteString
str MultipartState a
state)
                     Maybe ByteString
mboundary
          else do
              let info :: PartInfo
info = ByteString
-> Maybe ByteString
-> ByteString
-> PartDisposition
-> Headers
-> PartInfo
PartInfo ByteString
fieldName Maybe ByteString
fileName ByteString
contentType PartDisposition
disposition Headers
hdrs
              PartInfo
-> InputStream ByteString
-> MultipartState a
-> IO (MultipartState a)
handlePart PartInfo
info InputStream ByteString
str MultipartState a
state

    --------------------------------------------------------------------------
    handlePart :: PartInfo
-> InputStream ByteString
-> MultipartState a
-> IO (MultipartState a)
handlePart !PartInfo
info !InputStream ByteString
str !MultipartState a
ms = do
      Capture a
r <- PartInfo -> InputStream ByteString -> a -> IO (Capture a)
clientHandler PartInfo
info InputStream ByteString
str (MultipartState a -> a
forall a. MultipartState a -> a
accumulator MultipartState a
ms)
      case Capture a
r of
        Capture !ByteString
k !ByteString
v -> do
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
maxFormVars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= MultipartState a -> Int
forall a. MultipartState a -> Int
numFormVars MultipartState a
ms) IO ()
forall a. IO a
throwTooMuchVars
           MultipartState a -> IO (MultipartState a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MultipartState a -> IO (MultipartState a))
-> MultipartState a -> IO (MultipartState a)
forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString -> MultipartState a -> MultipartState a
forall a.
ByteString -> ByteString -> MultipartState a -> MultipartState a
addCapture ByteString
k ByteString
v MultipartState a
ms
        File !a
newAcc -> MultipartState a -> IO (MultipartState a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MultipartState a -> IO (MultipartState a))
-> MultipartState a -> IO (MultipartState a)
forall a b. (a -> b) -> a -> b
$! MultipartState a
ms { accumulator :: a
accumulator = a
newAcc
                                     , numFormFiles :: Int
numFormFiles = Int -> Int
forall a. Enum a => a -> a
succ (MultipartState a -> Int
forall a. MultipartState a -> Int
numFormFiles MultipartState a
ms)
                                     }

    throwTooMuchVars :: IO a
throwTooMuchVars =
        PolicyViolationException -> IO a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (PolicyViolationException -> IO a)
-> (Text -> PolicyViolationException) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PolicyViolationException
PolicyViolationException
        (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [ Text
"number of form inputs exceeded maximum of "
                   , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
maxFormVars ]

    --------------------------------------------------------------------------
    processMixed :: ByteString
-> InputStream ByteString
-> MultipartState a
-> ByteString
-> IO (MultipartState a)
processMixed !ByteString
fieldName !InputStream ByteString
str !MultipartState a
state !ByteString
mixedBoundary = do
        -- swallow the first boundary
        ByteString
_  <- Parser ByteString -> InputStream ByteString -> IO ByteString
forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream (ByteString -> Parser ByteString
parseFirstBoundary ByteString
mixedBoundary) InputStream ByteString
str
        InputStream MatchInfo
bm <- ByteString -> InputStream ByteString -> IO (InputStream MatchInfo)
search (ByteString -> ByteString
fullBoundary ByteString
mixedBoundary) InputStream ByteString
str
        (InputStream ByteString
 -> MultipartState a -> IO (MultipartState a))
-> InputStream MatchInfo
-> MultipartState a
-> IO (MultipartState a)
forall a.
(InputStream ByteString
 -> MultipartState a -> IO (MultipartState a))
-> InputStream MatchInfo
-> MultipartState a
-> IO (MultipartState a)
foldParts (ByteString
-> InputStream ByteString
-> MultipartState a
-> IO (MultipartState a)
mixedStream ByteString
fieldName) InputStream MatchInfo
bm MultipartState a
state


    --------------------------------------------------------------------------
    mixedStream :: ByteString
-> InputStream ByteString
-> MultipartState a
-> IO (MultipartState a)
mixedStream !ByteString
fieldName !InputStream ByteString
str !MultipartState a
acc = do
        Headers
hdrs <- InputStream ByteString -> IO Headers
takeHeaders InputStream ByteString
str

        let (ByteString
contentType, Maybe ByteString
_)           = Headers -> (ByteString, Maybe ByteString)
getContentType Headers
hdrs
        let (ByteString
_, Maybe ByteString
fileName, PartDisposition
disposition) = Headers -> (ByteString, Maybe ByteString, PartDisposition)
getFieldHeaderInfo Headers
hdrs

        let info :: PartInfo
info = ByteString
-> Maybe ByteString
-> ByteString
-> PartDisposition
-> Headers
-> PartInfo
PartInfo ByteString
fieldName Maybe ByteString
fileName ByteString
contentType PartDisposition
disposition Headers
hdrs
        PartInfo
-> InputStream ByteString
-> MultipartState a
-> IO (MultipartState a)
handlePart PartInfo
info InputStream ByteString
str MultipartState a
acc


------------------------------------------------------------------------------
getContentType :: Headers
               -> (ByteString, Maybe ByteString)
getContentType :: Headers -> (ByteString, Maybe ByteString)
getContentType Headers
hdrs = (ByteString
contentType, Maybe ByteString
boundary)
  where
    contentTypeValue :: ByteString
contentTypeValue = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"text/plain" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
                       CI ByteString -> Headers -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"content-type" Headers
hdrs

    eCT :: Either FilePath (ByteString, [(CI ByteString, ByteString)])
eCT = ByteString
-> Parser (ByteString, [(CI ByteString, ByteString)])
-> Either FilePath (ByteString, [(CI ByteString, ByteString)])
forall a. ByteString -> Parser a -> Either FilePath a
fullyParse ByteString
contentTypeValue Parser (ByteString, [(CI ByteString, ByteString)])
pContentTypeWithParameters
    (!ByteString
contentType, ![(CI ByteString, ByteString)]
params) = (FilePath -> (ByteString, [(CI ByteString, ByteString)]))
-> ((ByteString, [(CI ByteString, ByteString)])
    -> (ByteString, [(CI ByteString, ByteString)]))
-> Either FilePath (ByteString, [(CI ByteString, ByteString)])
-> (ByteString, [(CI ByteString, ByteString)])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((ByteString, [(CI ByteString, ByteString)])
-> FilePath -> (ByteString, [(CI ByteString, ByteString)])
forall a b. a -> b -> a
const (ByteString
"text/plain", [])) (ByteString, [(CI ByteString, ByteString)])
-> (ByteString, [(CI ByteString, ByteString)])
forall a. a -> a
id Either FilePath (ByteString, [(CI ByteString, ByteString)])
eCT

    boundary :: Maybe ByteString
boundary = CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
findParam CI ByteString
"boundary" [(CI ByteString, ByteString)]
params


------------------------------------------------------------------------------
getFieldHeaderInfo :: Headers -> (ByteString, Maybe ByteString, PartDisposition)
getFieldHeaderInfo :: Headers -> (ByteString, Maybe ByteString, PartDisposition)
getFieldHeaderInfo Headers
hdrs = (ByteString
fieldName, Maybe ByteString
fileName, PartDisposition
disposition)
  where
    contentDispositionValue :: ByteString
contentDispositionValue = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"unknown" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
                              CI ByteString -> Headers -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"content-disposition" Headers
hdrs

    eDisposition :: Either FilePath (ByteString, [(CI ByteString, ByteString)])
eDisposition = ByteString
-> Parser (ByteString, [(CI ByteString, ByteString)])
-> Either FilePath (ByteString, [(CI ByteString, ByteString)])
forall a. ByteString -> Parser a -> Either FilePath a
fullyParse ByteString
contentDispositionValue (Parser (ByteString, [(CI ByteString, ByteString)])
 -> Either FilePath (ByteString, [(CI ByteString, ByteString)]))
-> Parser (ByteString, [(CI ByteString, ByteString)])
-> Either FilePath (ByteString, [(CI ByteString, ByteString)])
forall a b. (a -> b) -> a -> b
$ (Char -> Bool)
-> Parser (ByteString, [(CI ByteString, ByteString)])
pValueWithParameters' (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

    (!ByteString
dispositionType, [(CI ByteString, ByteString)]
dispositionParameters) =
        (FilePath -> (ByteString, [(CI ByteString, ByteString)]))
-> ((ByteString, [(CI ByteString, ByteString)])
    -> (ByteString, [(CI ByteString, ByteString)]))
-> Either FilePath (ByteString, [(CI ByteString, ByteString)])
-> (ByteString, [(CI ByteString, ByteString)])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((ByteString, [(CI ByteString, ByteString)])
-> FilePath -> (ByteString, [(CI ByteString, ByteString)])
forall a b. a -> b -> a
const (ByteString
"unknown", [])) (ByteString, [(CI ByteString, ByteString)])
-> (ByteString, [(CI ByteString, ByteString)])
forall a. a -> a
id Either FilePath (ByteString, [(CI ByteString, ByteString)])
eDisposition

    disposition :: PartDisposition
disposition = ByteString -> PartDisposition
toPartDisposition ByteString
dispositionType

    fieldName :: ByteString
fieldName = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
findParam CI ByteString
"name" [(CI ByteString, ByteString)]
dispositionParameters

    fileName :: Maybe ByteString
fileName = CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
findParam CI ByteString
"filename" [(CI ByteString, ByteString)]
dispositionParameters


------------------------------------------------------------------------------
findParam :: (Eq a) => a -> [(a, b)] -> Maybe b
findParam :: a -> [(a, b)] -> Maybe b
findParam a
p = ((a, b) -> b) -> Maybe (a, b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd (Maybe (a, b) -> Maybe b)
-> ([(a, b)] -> Maybe (a, b)) -> [(a, b)] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> Bool) -> [(a, b)] -> Maybe (a, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
p) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst)


------------------------------------------------------------------------------
partStream :: InputStream MatchInfo -> IO (InputStream ByteString)
partStream :: InputStream MatchInfo -> IO (InputStream ByteString)
partStream InputStream MatchInfo
st = IO (Maybe ByteString) -> IO (InputStream ByteString)
forall a. IO (Maybe a) -> IO (InputStream a)
Streams.makeInputStream IO (Maybe ByteString)
go

  where
    go :: IO (Maybe ByteString)
go = do
        Maybe MatchInfo
s <- InputStream MatchInfo -> IO (Maybe MatchInfo)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream MatchInfo
st
        Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$! Maybe MatchInfo
s Maybe MatchInfo
-> (MatchInfo -> Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MatchInfo -> Maybe ByteString
forall (m :: * -> *). MonadPlus m => MatchInfo -> m ByteString
f

    f :: MatchInfo -> m ByteString
f (NoMatch ByteString
s) = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
s
    f MatchInfo
_           = m ByteString
forall (m :: * -> *) a. MonadPlus m => m a
mzero




------------------------------------------------------------------------------
-- | Assuming we've already identified the boundary value and split the input
-- up into parts which match and parts which don't, run the given 'ByteString'
-- InputStream over each part and grab a list of the resulting values.
--
-- TODO/FIXME: fix description
foldParts :: (InputStream ByteString -> MultipartState a -> IO (MultipartState a))
             -> InputStream MatchInfo
             -> (MultipartState a)
             -> IO (MultipartState a)
foldParts :: (InputStream ByteString
 -> MultipartState a -> IO (MultipartState a))
-> InputStream MatchInfo
-> MultipartState a
-> IO (MultipartState a)
foldParts InputStream ByteString -> MultipartState a -> IO (MultipartState a)
partFunc InputStream MatchInfo
stream = MultipartState a -> IO (MultipartState a)
go
  where
    part :: MultipartState a
-> InputStream ByteString -> IO (Maybe (MultipartState a))
part MultipartState a
acc InputStream ByteString
pStream = do
        Bool
isLast <- Parser Bool -> InputStream ByteString -> IO Bool
forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream Parser Bool
pBoundaryEnd InputStream ByteString
pStream

        if Bool
isLast
          then Maybe (MultipartState a) -> IO (Maybe (MultipartState a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MultipartState a)
forall a. Maybe a
Nothing
          else do
              !MultipartState a
x <- InputStream ByteString -> MultipartState a -> IO (MultipartState a)
partFunc InputStream ByteString
pStream MultipartState a
acc
              InputStream ByteString -> IO ()
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
pStream
              Maybe (MultipartState a) -> IO (Maybe (MultipartState a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MultipartState a) -> IO (Maybe (MultipartState a)))
-> Maybe (MultipartState a) -> IO (Maybe (MultipartState a))
forall a b. (a -> b) -> a -> b
$! MultipartState a -> Maybe (MultipartState a)
forall a. a -> Maybe a
Just MultipartState a
x

    go :: MultipartState a -> IO (MultipartState a)
go !MultipartState a
acc = do
      Maybe (MultipartState a)
cap <- InputStream MatchInfo -> IO (InputStream ByteString)
partStream InputStream MatchInfo
stream IO (InputStream ByteString)
-> (InputStream ByteString -> IO (Maybe (MultipartState a)))
-> IO (Maybe (MultipartState a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MultipartState a
-> InputStream ByteString -> IO (Maybe (MultipartState a))
part MultipartState a
acc
      IO (MultipartState a)
-> (MultipartState a -> IO (MultipartState a))
-> Maybe (MultipartState a)
-> IO (MultipartState a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MultipartState a -> IO (MultipartState a)
forall (m :: * -> *) a. Monad m => a -> m a
return MultipartState a
acc) MultipartState a -> IO (MultipartState a)
go Maybe (MultipartState a)
cap

    pBoundaryEnd :: Parser Bool
pBoundaryEnd = (Parser ByteString
eol Parser ByteString -> Parser Bool -> Parser Bool
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Parser ByteString
string ByteString
"--" Parser ByteString -> Parser Bool -> Parser Bool
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)


------------------------------------------------------------------------------
eol :: Parser ByteString
eol :: Parser ByteString
eol = (ByteString -> Parser ByteString
string ByteString
"\n") Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Parser ByteString
string ByteString
"\r\n")


------------------------------------------------------------------------------
pHeadersWithSeparator :: Parser [(ByteString,ByteString)]
pHeadersWithSeparator :: Parser [FormParam]
pHeadersWithSeparator = Parser [FormParam]
pHeaders Parser [FormParam] -> Parser ByteString -> Parser [FormParam]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString
crlf


------------------------------------------------------------------------------
toHeaders :: [(ByteString,ByteString)] -> Headers
toHeaders :: [FormParam] -> Headers
toHeaders [FormParam]
kvps = [(CI ByteString, ByteString)] -> Headers
H.fromList [(CI ByteString, ByteString)]
kvps'
  where
    kvps' :: [(CI ByteString, ByteString)]
kvps'     = (FormParam -> (CI ByteString, ByteString))
-> [FormParam] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> CI ByteString)
-> FormParam -> (CI ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk) [FormParam]
kvps


------------------------------------------------------------------------------
mAX_HDRS_SIZE :: Int64
mAX_HDRS_SIZE :: Int64
mAX_HDRS_SIZE = Int64
32768


------------------------------------------------------------------------------
withTempFile :: FilePath
             -> String
             -> ((FilePath, Handle) -> IO a)
             -> IO a
withTempFile :: FilePath -> FilePath -> ((FilePath, Handle) -> IO a) -> IO a
withTempFile FilePath
tmpl FilePath
temp (FilePath, Handle) -> IO a
handler =
    ((forall a. IO a -> IO a) -> IO a) -> IO a
forall (m :: * -> *) b.
MonadBaseControl IO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> IO (FilePath, Handle)
-> ((FilePath, Handle) -> IO [()])
-> ((FilePath, Handle) -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO (FilePath, Handle)
make (FilePath, Handle) -> IO [()]
cleanup (IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a)
-> ((FilePath, Handle) -> IO a) -> (FilePath, Handle) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, Handle) -> IO a
handler)

  where
    make :: IO (FilePath, Handle)
make           = FilePath -> IO (FilePath, Handle)
mkstemp (FilePath -> IO (FilePath, Handle))
-> FilePath -> IO (FilePath, Handle)
forall a b. (a -> b) -> a -> b
$ FilePath
tmpl FilePath -> ShowS
</> (FilePath
temp FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"XXXXXXX")
    cleanup :: (FilePath, Handle) -> IO [()]
cleanup (FilePath
fp,Handle
h) = [IO ()] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO ()] -> IO [()]) -> [IO ()] -> IO [()]
forall a b. (a -> b) -> a -> b
$ (IO () -> IO ()) -> [IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map IO () -> IO ()
forall z. IO z -> IO ()
gobble [Handle -> IO ()
hClose Handle
h, FilePath -> IO ()
removeFile FilePath
fp]

    t :: IO z -> IO (Either SomeException z)
    t :: IO z -> IO (Either SomeException z)
t = IO z -> IO (Either SomeException z)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
E.try

    gobble :: IO z -> IO ()
gobble = IO (Either SomeException z) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException z) -> IO ())
-> (IO z -> IO (Either SomeException z)) -> IO z -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO z -> IO (Either SomeException z)
forall z. IO z -> IO (Either SomeException z)
t