{-# 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 :: forall (m :: * -> *) a.
MonadSnap m =>
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 =
    forall (m :: * -> *) a.
MonadSnap m =>
UploadPolicy -> PartProcessor a -> m [a]
handleMultipart UploadPolicy
uploadPolicy PartInfo -> InputStream ByteString -> IO a
go

  where
    go :: PartInfo -> InputStream ByteString -> IO a
go PartInfo
partInfo InputStream ByteString
stream = 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 = forall a. a -> Maybe a -> a
fromMaybe 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
            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' forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` 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
                        (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                         Text -> PolicyViolationException
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 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show a
maxSize ])

        disallowed :: IO a
disallowed =
            PartInfo -> Either PolicyViolationException FilePath -> IO a
partHandler PartInfo
partInfo
                        (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                         Text -> PolicyViolationException
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
    { forall a. FormFile a -> ByteString
formFileName  :: !ByteString
         -- ^ Name of a field
    , forall a. FormFile a -> a
formFileValue :: a
         -- ^ Result of storing file
    } deriving (FormFile a -> FormFile a -> Bool
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, FormFile a -> FormFile a -> Bool
FormFile a -> FormFile a -> Ordering
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
Ord, Int -> FormFile a -> ShowS
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
     { forall a. UploadState a -> Int
numUploadedFiles :: !Int
     , forall a. 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 :: forall (m :: * -> *) a.
MonadSnap m =>
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) <- forall (m :: * -> *) a.
MonadSnap m =>
UploadPolicy -> PartFold a -> a -> m ([FormParam], a)
foldMultipart UploadPolicy
uploadPolicy PartInfo
-> InputStream ByteString -> UploadState a -> IO (UploadState a)
go (forall a. Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
UploadState Int
0 forall a. a -> a
id)
    forall (m :: * -> *) a. Monad m => a -> m a
return ([FormParam]
params, forall a. UploadState a -> [FormFile a] -> [FormFile a]
uploadedFiles UploadState a
st [])
  where
    go :: PartInfo
-> InputStream ByteString -> UploadState a -> IO (UploadState a)
go !PartInfo
partInfo InputStream ByteString
stream !UploadState a
st = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numUploads forall a. Ord a => a -> a -> Bool
>= Int
maxFiles) 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 = forall a. UploadState a -> Int
numUploadedFiles UploadState a
st
        files :: [FormFile a] -> [FormFile a]
files = 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 = forall a. a -> Maybe a -> a
fromMaybe 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' forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall {m :: * -> *} {a} {a}.
(MonadBase IO m, Show a) =>
a -> TooManyBytesReadException -> m a
tooMany Int64
maxFileSize
            let f :: FormFile a
f = forall a. ByteString -> a -> FormFile a
FormFile (PartInfo -> ByteString
partFieldName PartInfo
partInfo) a
r
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
UploadState (forall a. Enum a => a -> a
succ Int
numUploads) ([FormFile a] -> [FormFile a]
files forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FormFile a
f] 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
            !()
_ <- forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
str' forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall {m :: * -> *} {a} {a}.
(MonadBase IO m, Show a) =>
a -> TooManyBytesReadException -> m a
tooMany Int64
maxSize
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Int -> ([FormFile a] -> [FormFile a]) -> UploadState a
UploadState (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 = forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PolicyViolationException
PolicyViolationException forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
                            [Text
"number of files exceeded the maximum of "
                            ,FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
maxFiles) ]

        tooMany :: a -> TooManyBytesReadException -> m a
tooMany a
maxSize (TooManyBytesReadException
_ :: TooManyBytesReadException) =
            forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PolicyViolationException
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 forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) a.
MonadSnap m =>
UploadPolicy -> PartFold a -> a -> m ([FormParam], a)
foldMultipart UploadPolicy
uploadPolicy PartFold a
origPartHandler a
zero = do
    Headers
hdrs <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. HasHeaders a => a -> Headers
headers forall (m :: * -> *). MonadSnap m => m Request
getRequest
    let (ByteString
ct, Maybe ByteString
mbBoundary) = Headers -> (ByteString, Maybe ByteString)
getContentType Headers
hdrs

    Int -> IO ()
tickleTimeout <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max) forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier
    let bumpTimeout :: IO ()
bumpTimeout = Int -> IO ()
tickleTimeout 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 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 -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Capture a
File forall a b. (a -> b) -> a -> b
$ PartFold a
origPartHandler PartInfo
x InputStream ByteString
y a
acc

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

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

    -- RateTooSlowException will be caught and properly dealt with by
    -- runRequestBody
    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 forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
        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 :: forall (m :: * -> *) a.
MonadSnap m =>
UploadPolicy -> PartProcessor a -> m [a]
handleMultipart UploadPolicy
uploadPolicy PartProcessor a
origPartHandler = do
    ([FormParam]
captures, [a] -> [a]
files) <- forall (m :: * -> *) a.
MonadSnap m =>
UploadPolicy -> PartFold a -> a -> m ([FormParam], a)
foldMultipart UploadPolicy
uploadPolicy forall {c}.
PartInfo -> InputStream ByteString -> ([a] -> c) -> IO ([a] -> c)
partFold forall a. a -> a
id
    forall {f :: * -> *}. MonadSnap f => [FormParam] -> f ()
procCaptures [FormParam]
captures
    forall (m :: * -> *) a. Monad m => a -> m a
return 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
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a] -> c
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a
x]forall a. [a] -> [a] -> [a]
++)
    --------------------------------------------------------------------------
    procCaptures :: [FormParam] -> f ()
procCaptures []          = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    procCaptures [FormParam]
params = do
        Request
rq <- forall (m :: * -> *). MonadSnap m => m Request
getRequest
        forall (m :: * -> *). MonadSnap m => Request -> m ()
putRequest forall a b. (a -> b) -> a -> b
$ (Params -> Params) -> Request -> Request
modifyParams (\Params
m -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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) = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\[a]
_ [a]
ex -> (a
vforall 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 forall a b. (a -> b) -> a -> b
$ Request -> Params
rqPostParams Request
r
                         , rqParams :: Params
rqParams     = Params -> Params
f 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
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
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
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 forall a. Eq a => a -> a -> Bool
== ByteString
"attachment" = PartDisposition
DispositionAttachment
                    | ByteString
s forall a. Eq a => a -> a -> Bool
== ByteString
"file"       = PartDisposition
DispositionFile
                    | ByteString
s 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) = 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) = forall e. ExceptionWithReason e => e -> Text
exceptionReason e
e


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


------------------------------------------------------------------------------
uploadExceptionFromException :: ExceptionWithReason e => SomeException -> Maybe e
uploadExceptionFromException :: forall e. ExceptionWithReason e => SomeException -> Maybe e
uploadExceptionFromException SomeException
x = do
    WrappedFileUploadException e
e <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
    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 = forall e. ExceptionWithReason e => e -> SomeException
uploadExceptionToException
    fromException :: SomeException -> Maybe BadPartException
fromException = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_) =
        forall e. ExceptionWithReason e => e -> SomeException
uploadExceptionToException PolicyViolationException
e
    fromException :: SomeException -> Maybe PolicyViolationException
fromException = 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: "
                                            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
2forall 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall s a. (s -> a -> s) -> s -> InputStream a -> IO s
Streams.fold (\ByteString -> ByteString
f ByteString
c -> ByteString -> ByteString
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
LB.chunk ByteString
c) forall a. a -> a
id InputStream ByteString
str
   forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall (m :: * -> *) a.
MonadSnap m =>
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 <- forall a. IORef a -> IO a
IORef.readIORef IORef a
ref
          let x' :: a
x' = a -> a
f a
x
          a
x' seq :: forall a b. a -> b -> b
`seq` 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
          forall {a}. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [FilePath]
ioref (FilePath
fnforall a. a -> [a] -> [a]
:)
          Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering
          OutputStream ByteString
output <- Handle -> IO (OutputStream ByteString)
Streams.handleToOutputStream Handle
h
          forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream ByteString
input OutputStream ByteString
output
          Handle -> IO ()
hClose Handle
h
          forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
fn

      cleanup :: m ()
cleanup = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          [FilePath]
files <- forall a. IORef a -> IO a
IORef.readIORef IORef [FilePath]
ioref
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files forall a b. (a -> b) -> a -> b
$ \FilePath
fn ->
             FilePath -> IO ()
removeFile FilePath
fn forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall {f :: * -> *}. MonadBase IO f => IOError -> f ()
handleExists
      handleExists :: IOError -> f ()
handleExists IOError
e = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOError -> Bool
isDoesNotExistError IOError
e) forall a b. (a -> b) -> a -> b
$ 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 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 :: forall a.
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 forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Capture a
File forall a b. (a -> b) -> a -> b
$ PartFold a
fileHandler PartInfo
partInfo InputStream ByteString
stream a
acc
      else forall {a}. IO (Capture a)
variable forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall {m :: * -> *} {a}.
MonadBase IO m =>
TooManyBytesReadException -> m a
handler

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

    variable :: IO (Capture a)
variable = do
        !ByteString
x <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ByteString] -> ByteString
S.concat forall a b. (a -> b) -> a -> b
$
             Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan Int64
maxSize InputStream ByteString
stream forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. InputStream a -> IO [a]
Streams.toList
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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) =
        forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PolicyViolationException
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 forall a b. (a -> b) -> a -> b
$ 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 :: forall a.
FilePath
-> (PartInfo -> Either PolicyViolationException FilePath -> IO a)
-> PartProcessor a
fileReader FilePath
tmpdir PartInfo -> Either PolicyViolationException FilePath -> IO a
partProc PartInfo
partInfo InputStream ByteString
input =
    forall a.
FilePath -> FilePath -> ((FilePath, Handle) -> IO a) -> IO a
withTempFile FilePath
tmpdir FilePath
"snap-upload-" 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
        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 forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right FilePath
fn


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

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

------------------------------------------------------------------------------
addCapture :: ByteString -> ByteString -> MultipartState a -> MultipartState a
addCapture :: forall a.
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 = forall a. MultipartState a -> [FormParam] -> [FormParam]
capturedFields MultipartState a
ms forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FormParam
kv]forall a. [a] -> [a] -> [a]
++)
      !ms' :: MultipartState a
ms' = MultipartState a
ms { capturedFields :: [FormParam] -> [FormParam]
capturedFields = [FormParam] -> [FormParam]
f
                , numFormVars :: Int
numFormVars = forall a. Enum a => a -> a
succ (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 :: 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)
clientHandler !a
zeroAcc !InputStream ByteString
stream = IO ([FormParam], a)
go
  where
    --------------------------------------------------------------------------
    initialState :: MultipartState a
initialState = forall a.
Int -> Int -> ([FormParam] -> [FormParam]) -> a -> MultipartState a
MultipartState Int
0 Int
0 forall a. a -> a
id a
zeroAcc

    --------------------------------------------------------------------------
    go :: IO ([FormParam], a)
go = do
        -- swallow the first boundary
        ByteString
_        <- forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream (ByteString -> Parser ByteString 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 <- 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
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. MultipartState a -> [FormParam] -> [FormParam]
capturedFields MultipartState a
ms [], forall a. MultipartState a -> a
accumulator MultipartState a
ms)

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

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


    --------------------------------------------------------------------------
    takeHeaders :: InputStream ByteString -> IO Headers
takeHeaders !InputStream ByteString
str = IO Headers
hdrs forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` 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
            forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [FormParam] -> Headers
toHeaders forall a b. (a -> b) -> a -> b
$ forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream Parser [FormParam]
pHeadersWithSeparator InputStream ByteString
str'

        handler :: TooManyBytesReadException -> m a
handler (TooManyBytesReadException
_ :: TooManyBytesReadException) =
            forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO 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 forall a. Eq a => a -> a -> Bool
== ByteString
"multipart/mixed"
          then forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> BadPartException
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 (forall a. MultipartState a -> a
accumulator MultipartState a
ms)
      case Capture a
r of
        Capture !ByteString
k !ByteString
v -> do
           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
maxFormVars forall a. Ord a => a -> a -> Bool
<= forall a. MultipartState a -> Int
numFormVars MultipartState a
ms) forall {a}. IO a
throwTooMuchVars
           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a.
ByteString -> ByteString -> MultipartState a -> MultipartState a
addCapture ByteString
k ByteString
v MultipartState a
ms
        File !a
newAcc -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! MultipartState a
ms { accumulator :: a
accumulator = a
newAcc
                                     , numFormFiles :: Int
numFormFiles = forall a. Enum a => a -> a
succ (forall a. MultipartState a -> Int
numFormFiles MultipartState a
ms)
                                     }

    throwTooMuchVars :: IO a
throwTooMuchVars =
        forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PolicyViolationException
PolicyViolationException
        forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [ Text
"number of form inputs exceeded maximum of "
                   , FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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
_  <- forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream (ByteString -> Parser ByteString 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
        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 = forall a. a -> Maybe a -> a
fromMaybe ByteString
"text/plain" forall a b. (a -> b) -> a -> b
$
                       forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"content-type" Headers
hdrs

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

    boundary :: Maybe ByteString
boundary = 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 = forall a. a -> Maybe a -> a
fromMaybe ByteString
"unknown" forall a b. (a -> b) -> a -> b
$
                              forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"content-disposition" Headers
hdrs

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

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

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

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

    fileName :: Maybe ByteString
fileName = 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 :: forall a b. Eq a => a -> [(a, b)] -> Maybe b
findParam a
p = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== a
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)


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

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

    f :: MatchInfo -> m ByteString
f (NoMatch ByteString
s) = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
s
    f MatchInfo
_           = 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 :: forall a.
(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 <- forall r. Parser r -> InputStream ByteString -> IO r
parseFromStream Parser ByteString Bool
pBoundaryEnd InputStream ByteString
pStream

        if Bool
isLast
          then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
          else do
              !MultipartState a
x <- InputStream ByteString -> MultipartState a -> IO (MultipartState a)
partFunc InputStream ByteString
pStream MultipartState a
acc
              forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
pStream
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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 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
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return MultipartState a
acc) MultipartState a -> IO (MultipartState a)
go Maybe (MultipartState a)
cap

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


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


------------------------------------------------------------------------------
pHeadersWithSeparator :: Parser [(ByteString,ByteString)]
pHeadersWithSeparator :: Parser [FormParam]
pHeadersWithSeparator = Parser [FormParam]
pHeaders forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString 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'     = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first 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 :: forall a.
FilePath -> FilePath -> ((FilePath, Handle) -> IO a) -> IO a
withTempFile FilePath
tmpl FilePath
temp (FilePath, Handle) -> IO a
handler =
    forall (m :: * -> *) b.
MonadBaseControl IO m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> 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 (forall a. IO a -> IO a
restore 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 forall a b. (a -> b) -> a -> b
$ FilePath
tmpl FilePath -> ShowS
</> (FilePath
temp forall a. [a] -> [a] -> [a]
++ FilePath
"XXXXXXX")
    cleanup :: (FilePath, Handle) -> IO [()]
cleanup (FilePath
fp,Handle
h) = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {z}. IO z -> IO ()
gobble [Handle -> IO ()
hClose Handle
h, FilePath -> IO ()
removeFile FilePath
fp]

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

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