servant-multipart 0.11.6 → 0.13.0
raw patch · 5 files changed
Files
- CHANGELOG.md +52/−0
- exe/Upload.hs +0/−85
- servant-multipart.cabal +23/−43
- src/Servant/Multipart.hs +199/−418
- test/Test.hs +170/−12
CHANGELOG.md view
@@ -1,3 +1,55 @@+0.13.0+------++- **Breaking:** under `Lenient`, the handler now receives+ `Either CheckError a` instead of `Either String a`. `CheckError`+ distinguishes `fromMultipart` failures (`ParseError`), invalid UTF-8+ (`DecodeError`) and exceeded body parsing limits (`LimitError`).+- **Breaking:** forms whose input names, input values, file names or file+ content types are not valid UTF-8 are rejected with a 400 response instead+ of throwing an exception+ [#84](https://github.com/haskell-servant/servant-multipart/pull/84).+- **Breaking:** forms that exceed a `generalOptions` limit are rejected with+ a 4xx response instead of a 500. Exceeding a size limit responds with 413,+ exceeding a part header limit responds with 431, and other limits respond+ through the `ErrorFormatters` in the context+ [#85](https://github.com/haskell-servant/servant-multipart/pull/85).+ Under Warp, size and part header limits already responded with 413 and+ 431, but with Warp's plain-text body; the body now comes from the+ `ErrorFormatters`.+- **Breaking:** `defaultMultipartOptions` now limits each file to 25 MiB.+- **Breaking:** requests whose content type is not+ `application/x-www-form-urlencoded` or `multipart/form-data` with a+ boundary are rejected with 415 instead of 400, and the response is built+ by the `ErrorFormatters` in the context. The rejection is no longer+ fatal, so later alternatives of `:<|>` are tried, as with `ReqBody`.+- `lookupInput` and `lookupFile` moved to `servant-multipart-api`; they+ are still re-exported from `Servant.Multipart`.+- Re-export the new `lookupAllInputs`, `lookupAllFiles`, `lookupInputAs`+ and `lookupAllInputsAs` from `servant-multipart-api`+ [#75](https://github.com/haskell-servant/servant-multipart/pull/75).+- Export the `LookupContext` class.+- **Breaking:** the `HasDocs` and `HasForeign` instances now cover+ `MultipartForm'` with any modifiers, not only `MultipartForm`. Remove any+ instances you wrote for `MultipartForm' '[Lenient]`, since they now+ overlap.+- Drop the `string-conversions` dependency.+- Require GHC >= 9.4 and servant >= 0.20.3; support up to GHC 9.12+ [#81](https://github.com/haskell-servant/servant-multipart/pull/81).++0.12.1+------++- split package into api, server and client parts+ [#51](https://github.com/haskell-servant/servant-multipart/pull/51)++0.12+----++- support servant-0.18+- version bump for breaking change in+ [#36](https://github.com/haskell-servant/servant-multipart/pull/36)+ 0.11.6 ------
− exe/Upload.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--import Control.Concurrent-import Control.Monad-import Control.Monad.IO.Class-import Network.Socket (withSocketsDo)-import Network.HTTP.Client hiding (Proxy)-import Network.Wai.Handler.Warp-import Servant-import Servant.Multipart-import System.Environment (getArgs)-import Servant.Client (client, runClientM, mkClientEnv)-import Servant.Client.Core (BaseUrl(BaseUrl), Scheme(Http))--import qualified Data.ByteString.Lazy as LBS---- Our API, which consists in a single POST endpoint at /--- that takes a multipart/form-data request body and--- pretty-prints the data it got to stdout before returning 0.-type API = MultipartForm Mem (MultipartData Mem) :> Post '[JSON] Integer---- We want to load our file from disk, so we need to convert--- the 'Mem's in the serverside API to 'Tmp's-type family MemToTmp api where- MemToTmp (a :<|> b) = MemToTmp a :<|> MemToTmp b- MemToTmp (a :> b) = MemToTmp a :> MemToTmp b- MemToTmp (MultipartForm Mem (MultipartData Mem)) = MultipartForm Tmp (MultipartData Tmp)- MemToTmp a = a--api :: Proxy API-api = Proxy--clientApi :: Proxy (MemToTmp API)-clientApi = Proxy---- The handler for our single endpoint.--- Its concrete type is:--- MultipartData -> Handler Integer------ MultipartData consists in textual inputs,--- accessible through its "inputs" field, as well--- as files, accessible through its "files" field.-upload :: Server API-upload multipartData = do- liftIO $ do- putStrLn "Inputs:"- forM_ (inputs multipartData) $ \input ->- putStrLn $ " " ++ show (iName input)- ++ " -> " ++ show (iValue input)-- forM_ (files multipartData) $ \file -> do- let content = fdPayload file- putStrLn $ "Content of " ++ show (fdFileName file)- LBS.putStr content- return 0--startServer :: IO ()-startServer = run 8080 (serve api upload)--main :: IO ()-main = do- args <- getArgs- case args of- ("run":_) -> withSocketsDo $ do- _ <- forkIO startServer- -- we fork the server in a separate thread and send a test- -- request to it from the main thread.- manager <- newManager defaultManagerSettings- boundary <- genBoundary- let burl = BaseUrl Http "localhost" 8080 ""- runC cli = runClientM cli (mkClientEnv manager burl)- resp <- runC $ client clientApi (boundary, form)- print resp- _ -> putStrLn "Pass run to run"-- where form = MultipartData [ Input "title" "World"- , Input "text" "Hello"- ]- [ FileData "file" "./servant-multipart.cabal"- "text/plain" "./servant-multipart.cabal"- , FileData "otherfile" "./Setup.hs" "text/plain" "./Setup.hs"- ]
servant-multipart.cabal view
@@ -1,11 +1,8 @@ name: servant-multipart-version: 0.11.6+version: 0.13.0 synopsis: multipart/form-data (e.g file upload) support for servant description:- This package adds support for file upload to the servant ecosystem. It draws- on ideas and code from several people who participated in the- (in)famous [ticket #133](https://github.com/haskell-servant/servant/issues/133) on- servant's issue tracker.+ This package adds server-side support of file upload to the servant ecosystem. homepage: https://github.com/haskell-servant/servant-multipart#readme license: BSD3@@ -17,7 +14,12 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md-tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3+tested-with:+ GHC ==9.4.8+ || ==9.6.3+ || ==9.8.4+ || ==9.10.3+ || ==9.12.4 library default-language: Haskell2010@@ -26,46 +28,24 @@ -- ghc boot libs build-depends:- array >=0.5.1.1 && <0.6- , base >=4.9 && <5- , bytestring >=0.10.8.1 && <0.11+ base >=4.17 && <5+ , bytestring >=0.11 && <0.13+ , deepseq >=1.4.8 && <1.6 , directory >=1.3 && <1.4- , text >=1.2.3.0 && <1.3- , transformers >=0.5.2.0 && <0.6- , random >=0.1.1 && <1.2+ , text >=2.0 && <2.2 -- other dependencies build-depends:- http-media >=0.7.1.3 && <0.9- , lens >=4.17 && <4.20- , resourcet >=1.2.2 && <1.3- , servant >=0.16 && <0.18- , servant-client-core >=0.16 && <0.18- , servant-docs >=0.10 && <0.16- , servant-foreign >=0.15 && <0.16- , servant-server >=0.16 && <0.18- , string-conversions >=0.4.0.1 && <0.5- , wai >=3.2.1.2 && <3.3- , wai-extra >=3.0.24.3 && <3.1--executable upload- hs-source-dirs: exe- main-is: Upload.hs- default-language: Haskell2010- build-depends:- base- , bytestring- , http-client- , network >=2.8 && <3.2- , servant- , servant-multipart- , servant-server- , servant-client- , servant-client-core- , text- , transformers- , wai- , warp+ servant-multipart-api == 0.13.*+ , lens >=4.17 && <5.4+ , resourcet >=1.3.0 && <1.4+ , servant >=0.20.3 && <0.21+ , servant-docs >=0.13 && <0.14+ , servant-foreign >=0.16 && <0.17+ , servant-server >=0.20.3 && <0.21+ , wai >=3.2.5 && <3.3+ , wai-extra >=3.1.18 && <3.2+ , warp >=3.3.22 && <3.5 test-suite servant-multipart-test type: exitcode-stdio-1.0@@ -78,10 +58,10 @@ , http-types , servant-multipart , servant-server- , string-conversions , tasty , tasty-wai , text+ , wai-extra source-repository head type: git
src/Servant/Multipart.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}@@ -14,10 +13,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-}--- | @multipart/form-data@ support for servant.------ This is mostly useful for adding file upload support to--- an API. See haddocks of 'MultipartForm' for an introduction.+-- | @multipart/form-data@ server-side support for servant.+-- See servant-multipart-api for the API definitions. module Servant.Multipart ( MultipartForm , MultipartForm'@@ -25,6 +22,13 @@ , FromMultipart(..) , lookupInput , lookupFile+ , lookupAllInputs+ , lookupAllFiles + , lookupInputAs + , lookupAllInputsAs + , CheckError(..)+ , LimitExceeded(..)+ , InvalidUtf8(..) , MultipartOptions(..) , defaultMultipartOptions , MultipartBackend(..)@@ -34,275 +38,95 @@ , defaultTmpBackendOptions , Input(..) , FileData(..)- -- * servant-client- , genBoundary- , ToMultipart(..)- , multipartToBody -- * servant-docs , ToMultipartSample(..)+ , LookupContext(..) ) where +import Servant.Multipart.API++import Control.DeepSeq (NFData (rnf)) import Control.Lens ((<>~), (&), view, (.~))-import Control.Monad (replicateM)+import Control.Monad (unless) import Control.Monad.IO.Class import Control.Monad.Trans.Resource-import Data.Array (listArray, (!))-import Data.List (find, foldl')+import Data.Bifunctor (first) import Data.Maybe-import Data.Monoid-import Data.String.Conversions (cs) import Data.Text (Text, unpack)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Text.Encoding (decodeUtf8') import Data.Typeable-import Network.HTTP.Media.MediaType ((//), (/:)) import Network.Wai+import Network.Wai.Handler.Warp (InvalidRequest (PayloadTooLarge, RequestHeaderFieldsTooLarge)) import Network.Wai.Parse import Servant hiding (contentType) import Servant.API.Modifiers (FoldLenient)-import Servant.Client.Core (HasClient(..), RequestBody(RequestBodySource), setRequestBody) import Servant.Docs hiding (samples) import Servant.Foreign hiding (contentType) import Servant.Server.Internal-import Servant.Types.SourceT (SourceT(..), source, StepT(..), fromActionStep) import System.Directory-import System.IO (IOMode(ReadMode), withFile)-import System.Random (getStdRandom, Random(randomR)) -import qualified Data.ByteString as SBS-import qualified Data.ByteString.Lazy as LBS---- | Combinator for specifying a @multipart/form-data@ request--- body, typically (but not always) issued from an HTML @\<form\>@.------ @multipart/form-data@ can't be made into an ordinary content--- type for now in servant because it doesn't just decode the--- request body from some format but also performs IO in the case--- of writing the uploaded files to disk, e.g in @/tmp@, which is--- not compatible with servant's vision of a content type as things--- stand now. This also means that 'MultipartForm' can't be used in--- conjunction with 'ReqBody' in an endpoint.------ The 'tag' type parameter instructs the function to handle data--- either as data to be saved to temporary storage ('Tmp') or saved to--- memory ('Mem').------ The 'a' type parameter represents the Haskell type to which--- you are going to decode the multipart data to, where the--- multipart data consists in all the usual form inputs along--- with the files sent along through @\<input type="file"\>@--- fields in the form.------ One option provided out of the box by this library is to decode--- to 'MultipartData'.------ Example:------ @--- type API = MultipartForm Tmp (MultipartData Tmp) :> Post '[PlainText] String------ api :: Proxy API--- api = Proxy------ server :: MultipartData Tmp -> Handler String--- server multipartData = return str------ where str = "The form was submitted with "--- ++ show nInputs ++ " textual inputs and "--- ++ show nFiles ++ " files."--- nInputs = length (inputs multipartData)--- nFiles = length (files multipartData)--- @------ You can alternatively provide a 'FromMultipart' instance--- for some type of yours, allowing you to regroup data--- into a structured form and potentially selecting--- a subset of the entire form data that was submitted.------ Example, where we only look extract one input, /username/,--- and one file, where the corresponding input field's /name/--- attribute was set to /pic/:------ @--- data User = User { username :: Text, pic :: FilePath }------ instance FromMultipart Tmp User where--- fromMultipart multipartData =--- User \<$\> lookupInput "username" multipartData--- \<*\> fmap fdPayload (lookupFile "pic" multipartData)------ type API = MultipartForm Tmp User :> Post '[PlainText] String------ server :: User -> Handler String--- server usr = return str------ where str = username usr ++ "'s profile picture"--- ++ " got temporarily uploaded to "--- ++ pic usr ++ " and will be removed from there "--- ++ " after this handler has run."--- @------ Note that the behavior of this combinator is configurable,--- by using 'serveWith' from servant-server instead of 'serve',--- which takes an additional 'Context' argument. It simply is an--- heterogeneous list where you can for example store--- a value of type 'MultipartOptions' that has the configuration that--- you want, which would then get picked up by servant-multipart.------ __Important__: as mentionned in the example above,--- the file paths point to temporary files which get removed--- after your handler has run, if they are still there. It is--- therefore recommended to move or copy them somewhere in your--- handler code if you need to keep the content around.-type MultipartForm tag a = MultipartForm' '[] tag a---- | 'MultipartForm' which can be modified with 'Servant.API.Modifiers.Lenient'.-data MultipartForm' (mods :: [*]) tag a---- | What servant gets out of a @multipart/form-data@ form submission.------ The type parameter 'tag' tells if 'MultipartData' is stored as a--- temporary file or stored in memory. 'tag' is type of either 'Mem'--- or 'Tmp'.------ The 'inputs' field contains a list of textual 'Input's, where--- each input for which a value is provided gets to be in this list,--- represented by the input name and the input value. See haddocks for--- 'Input'.------ The 'files' field contains a list of files that were sent along with the--- other inputs in the form. Each file is represented by a value of type--- 'FileData' which among other things contains the path to the temporary file--- (to be removed when your handler is done running) with a given uploaded--- file's content. See haddocks for 'FileData'.-data MultipartData tag = MultipartData- { inputs :: [Input]- , files :: [FileData tag]- }+import qualified Control.Exception as E+import qualified Data.ByteString as SBS+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE fromRaw :: forall tag. ([Network.Wai.Parse.Param], [File (MultipartResult tag)])- -> MultipartData tag-fromRaw (inputs, files) = MultipartData is fs+ -> Either CheckError (MultipartData tag)+fromRaw (inputs, files) =+ MultipartData <$> traverse toInput inputs <*> traverse toFile files - where is = map (\(name, val) -> Input (dec name) (dec val)) inputs- fs = map toFile files+ where toInput (iname, val) =+ Input <$> decInput "name" iname iname+ <*> decInput "value" iname val - toFile :: File (MultipartResult tag) -> FileData tag+ toFile :: File (MultipartResult tag) -> Either CheckError (FileData tag) toFile (iname, fileinfo) =- FileData (dec iname)- (dec $ fileName fileinfo)- (dec $ fileContentType fileinfo)- (fileContent fileinfo)-- dec = decodeUtf8---- | Representation for an uploaded file, usually resulting from--- picking a local file for an HTML input that looks like--- @\<input type="file" name="somefile" /\>@.-data FileData tag = FileData- { fdInputName :: Text -- ^ @name@ attribute of the corresponding- -- HTML @\<input\>@- , fdFileName :: Text -- ^ name of the file on the client's disk- , fdFileCType :: Text -- ^ MIME type for the file- , fdPayload :: MultipartResult tag- -- ^ path to the temporary file that has the- -- content of the user's original file. Only- -- valid during the execution of your handler as- -- it gets removed right after, which means you- -- really want to move or copy it in your handler.- }--deriving instance Eq (MultipartResult tag) => Eq (FileData tag)-deriving instance Show (MultipartResult tag) => Show (FileData tag)---- | Lookup a file input with the given @name@ attribute.-lookupFile :: Text -> MultipartData tag -> Either String (FileData tag)-lookupFile iname =- maybe (Left $ "File " <> cs iname <> " not found") Right- . find ((==iname) . fdInputName)- . files---- | Representation for a textual input (any @\<input\>@ type but @file@).------ @\<input name="foo" value="bar"\ />@ would appear as @'Input' "foo" "bar"@.-data Input = Input- { iName :: Text -- ^ @name@ attribute of the input- , iValue :: Text -- ^ value given for that input- } deriving (Eq, Show)+ FileData <$> decFile "name" iname iname+ <*> decFile "file name" iname (fileName fileinfo)+ <*> decFile "content type" iname (fileContentType fileinfo)+ <*> pure (fileContent fileinfo) --- | Lookup a textual input with the given @name@ attribute.-lookupInput :: Text -> MultipartData tag -> Either String Text-lookupInput iname =- maybe (Left $ "Field " <> cs iname <> " not found") (Right . iValue)- . find ((==iname) . iName)- . inputs+ decInput = dec "input"+ decFile = dec "file input" --- | 'MultipartData' is the type representing--- @multipart/form-data@ form inputs. Sometimes--- you may instead want to work with a more structured type--- of yours that potentially selects only a fraction of--- the data that was submitted, or just reshapes it to make--- it easier to work with. The 'FromMultipart' class is exactly--- what allows you to tell servant how to turn "raw" multipart--- data into a value of your nicer type.------ @--- data User = User { username :: Text, pic :: FilePath }------ instance FromMultipart Tmp User where--- fromMultipart form =--- User \<$\> lookupInput "username" (inputs form)--- \<*\> fmap fdPayload (lookupFile "pic" $ files form)--- @-class FromMultipart tag a where- -- | Given a value of type 'MultipartData', which consists- -- in a list of textual inputs and another list for- -- files, try to extract a value of type @a@. When- -- extraction fails, servant errors out with status code 400.- fromMultipart :: MultipartData tag -> Either String a+ dec :: String -> String -> SBS.ByteString -> SBS.ByteString+ -> Either CheckError Text+ dec kind part iname raw =+ case decodeUtf8' raw of+ Right text -> Right text+ Left _ -> Left $ DecodeError $ InvalidUtf8 part kind iname -instance FromMultipart tag (MultipartData tag) where- fromMultipart = Right+class MultipartBackend tag where+ type MultipartBackendOptions tag :: * --- | Allows you to tell servant how to turn a more structured type--- into a 'MultipartData', which is what is actually sent by the--- client.------ @--- data User = User { username :: Text, pic :: FilePath }------ instance toMultipart Tmp User where--- toMultipart user = MultipartData [Input "username" $ username user]--- [FileData "pic"--- (pic user)--- "image/png"--- (pic user)--- ]--- @-class ToMultipart tag a where- -- | Given a value of type 'a', convert it to a- -- 'MultipartData'.- toMultipart :: a -> MultipartData tag+ backend :: Proxy tag+ -> MultipartBackendOptions tag+ -> InternalState+ -> ignored1+ -> ignored2+ -> IO SBS.ByteString+ -> IO (MultipartResult tag) -instance ToMultipart tag (MultipartData tag) where- toMultipart = id+ defaultBackendOptions :: Proxy tag -> MultipartBackendOptions tag -- | Upon seeing @MultipartForm a :> ...@ in an API type, --- servant-server will hand a value of type @a@ to your handler -- assuming the request body's content type is--- @multipart/form-data@ and the call to 'fromMultipart' succeeds.+-- @multipart/form-data@, the form's names, values, file names and+-- content types are valid UTF-8, and the call to 'fromMultipart'+-- succeeds. instance ( FromMultipart tag a , MultipartBackend tag , LookupContext config (MultipartOptions tag)+ , LookupContext config ErrorFormatters , SBoolI (FoldLenient mods) , HasServer sublayout config ) => HasServer (MultipartForm' mods tag a :> sublayout) config where type ServerT (MultipartForm' mods tag a :> sublayout) m =- If (FoldLenient mods) (Either String a) a -> ServerT sublayout m+ If (FoldLenient mods) (Either CheckError a) a -> ServerT sublayout m -#if MIN_VERSION_servant_server(0,12,0) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy sublayout) pc nt . s-#endif route Proxy config subserver = route psub config subserver'@@ -312,165 +136,139 @@ popts = Proxy :: Proxy (MultipartOptions tag) multipartOpts = fromMaybe (defaultMultipartOptions pbak) $ lookupContext popts config- subserver' = addMultipartHandling @tag @a @mods pbak multipartOpts subserver---- | Upon seeing @MultipartForm a :> ...@ in an API type,--- servant-client will take a parameter of type @(LBS.ByteString, a)@,--- where the bytestring is the boundary to use (see 'genBoundary'), and--- replace the request body with the contents of the form.-instance (ToMultipart tag a, HasClient m api, MultipartBackend tag)- => HasClient m (MultipartForm' mods tag a :> api) where-- type Client m (MultipartForm' mods tag a :> api) =- (LBS.ByteString, a) -> Client m api-- clientWithRoute pm _ req (boundary, param) =- clientWithRoute pm (Proxy @api) $ setRequestBody newBody newMedia req- where- newBody = multipartToBody boundary $ toMultipart @tag param- newMedia = "multipart" // "form-data" /: ("boundary", LBS.toStrict boundary)-- hoistClientMonad pm _ f cl = \a ->- hoistClientMonad pm (Proxy @api) f (cl a)---- | Generates a boundary to be used to separate parts of the multipart.--- Requires 'IO' because it is randomized.-genBoundary :: IO LBS.ByteString-genBoundary = LBS.pack- . map (validChars !)- <$> indices- where- -- the standard allows up to 70 chars, but most implementations seem to be- -- in the range of 40-60, so we pick 55- indices = replicateM 55 . getStdRandom $ randomR (0,61)- -- Following Chromium on this one:- -- > The RFC 2046 spec says the alphanumeric characters plus the- -- > following characters are legal for boundaries: '()+_,-./:=?- -- > However the following characters, though legal, cause some sites- -- > to fail: (),./:=+- -- https://github.com/chromium/chromium/blob/6efa1184771ace08f3e2162b0255c93526d1750d/net/base/mime_util.cc#L662-L670- validChars = listArray (0 :: Int, 61)- -- 0-9- [ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37- , 0x38, 0x39, 0x41, 0x42- -- A-Z, a-z- , 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a- , 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 0x51, 0x52- , 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a- , 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68- , 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70- , 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78- , 0x79, 0x7a- ]---- | Given a bytestring for the boundary, turns a `MultipartData` into--- a 'RequestBody'-multipartToBody :: forall tag.- MultipartBackend tag- => LBS.ByteString- -> MultipartData tag- -> RequestBody-multipartToBody boundary mp = RequestBodySource $ files' <> source ["--", boundary, "--"]- where- -- at time of writing no Semigroup or Monoid instance exists for SourceT and StepT- -- in releases of Servant; they are in master though- (SourceT l) `mappend'` (SourceT r) = SourceT $ \k ->- l $ \lstep ->- r $ \rstep ->- k (appendStep lstep rstep)- appendStep Stop r = r- appendStep (Error err) _ = Error err- appendStep (Skip s) r = appendStep s r- appendStep (Yield x s) r = Yield x (appendStep s r)- appendStep (Effect ms) r = Effect $ (flip appendStep r <$> ms)- mempty' = SourceT ($ Stop)- crlf = "\r\n"- lencode = LBS.fromStrict . encodeUtf8- renderInput input = renderPart (lencode . iName $ input)- "text/plain"- ""- (source . pure . lencode . iValue $ input)- inputs' = foldl' (\acc x -> acc `mappend'` renderInput x) mempty' (inputs mp)- renderFile :: FileData tag -> SourceIO LBS.ByteString- renderFile file = renderPart (lencode . fdInputName $ file)- (lencode . fdFileCType $ file)- ((flip mappend) "\"" . mappend "; filename=\""- . lencode- . fdFileName $ file)- (loadFile (Proxy @tag) . fdPayload $ file)- files' = foldl' (\acc x -> acc `mappend'` renderFile x) inputs' (files mp)- renderPart name contentType extraParams payload =- source [ "--"- , boundary- , crlf- , "Content-Disposition: form-data; name=\""- , name- , "\""- , extraParams- , crlf- , "Content-Type: "- , contentType- , crlf- , crlf- ] `mappend'` payload `mappend'` source [crlf]+ subserver' = addMultipartHandling @tag @a @mods @config pbak multipartOpts config subserver --- Try and extract the request body as multipart/form-data,--- returning the data as well as the resourcet InternalState--- that allows us to properly clean up the temporary files--- later on. check :: MultipartBackend tag => Proxy tag -> MultipartOptions tag- -> DelayedIO (MultipartData tag)+ -> DelayedIO (Either CheckError (MultipartData tag)) check pTag tag = withRequest $ \request -> do st <- liftResourceT getInternalState- rawData <- liftIO- $ parseRequestBodyEx- parseOpts- (backend pTag (backendOptions tag) st)- request- return (fromRaw rawData)+ let parse = fromRaw <$> parseRequestBodyEx parseOpts (backend pTag (backendOptions tag) st) request+ liftIO $+ E.catchJust invalidRequestLimit+ (E.handle (pure . Left . LimitError . requestParseLimit) parse)+ (pure . Left . LimitError) where parseOpts = generalOptions tag +-- | Why a @multipart/form-data@ request body was not decoded. Under+-- 'Servant.API.Modifiers.Lenient', the handler is passed this instead of+-- the request being rejected.+data CheckError+ = ParseError String+ -- ^ 'fromMultipart' failed.+ | DecodeError InvalidUtf8+ -- ^ The form's text is not valid UTF-8.+ | LimitError LimitExceeded+ -- ^ The form exceeds one of the 'generalOptions' limits.+ deriving (Eq, Show)++instance NFData CheckError where+ rnf (ParseError message) = rnf message+ rnf (DecodeError limit) = rnf limit+ rnf (LimitError limit) = rnf limit++-- | A @multipart/form-data@ request body that exceeds one of the+-- 'generalOptions' limits.+data LimitExceeded = LimitExceeded+ { statusOverride :: Maybe (Int, String)+ -- ^ The status code and reason phrase that the rejection responds with+ -- in place of the one from the 'ErrorFormatters', if any.+ , limitMessage :: String+ } deriving (Eq, Show)++instance NFData LimitExceeded where+ rnf (LimitExceeded override message) = rnf override `seq` rnf message++data InvalidUtf8 = InvalidUtf8+ { kind :: String+ , part :: String+ , iname :: SBS.ByteString+ } deriving (Eq, Show)++instance NFData InvalidUtf8 where+ rnf (InvalidUtf8 {..}) = rnf kind `seq` rnf part `seq` rnf iname++requestParseLimit :: RequestParseException -> LimitExceeded+requestParseLimit e = case e of+ MaxParamSizeExceeded _ -> LimitExceeded payloadTooLarge "the form exceeds a size limit"+ ParamNameTooLong _ maxLength ->+ LimitExceeded Nothing $ "an input name exceeds " <> show maxLength <> " bytes"+ FilenameTooLong _ maxLength ->+ LimitExceeded Nothing $ "a file input name exceeds " <> show maxLength <> " bytes"+ MaxFileNumberExceeded maxFiles ->+ LimitExceeded Nothing $ "the form has more than " <> show maxFiles <> " files"+ TooManyHeaderLines _ -> LimitExceeded headerFieldsTooLarge "a part has too many header lines"++invalidRequestLimit :: InvalidRequest -> Maybe LimitExceeded+invalidRequestLimit e = case e of+ PayloadTooLarge -> Just $ LimitExceeded payloadTooLarge "the form exceeds a size limit"+ RequestHeaderFieldsTooLarge ->+ Just $ LimitExceeded headerFieldsTooLarge "a part header line exceeds the length limit"+ _ -> Nothing++payloadTooLarge :: Maybe (Int, String)+payloadTooLarge = Just (errHTTPCode err413, errReasonPhrase err413)++headerFieldsTooLarge :: Maybe (Int, String)+headerFieldsTooLarge = Just (431, "Request Header Fields Too Large")++unsupportedMediaType :: Maybe (Int, String)+unsupportedMediaType = Just (errHTTPCode err415, errReasonPhrase err415)+ -- Add multipart extraction support to a Delayed.-addMultipartHandling :: forall tag multipart (mods :: [*]) env a. (FromMultipart tag multipart, MultipartBackend tag)+addMultipartHandling :: forall tag multipart (mods :: [*]) config env a.+ ( FromMultipart tag multipart+ , MultipartBackend tag+ , LookupContext config ErrorFormatters+ ) => SBoolI (FoldLenient mods) => Proxy tag -> MultipartOptions tag- -> Delayed env (If (FoldLenient mods) (Either String multipart) multipart -> a)+ -> Context config+ -> Delayed env (If (FoldLenient mods) (Either CheckError multipart) multipart -> a) -> Delayed env a-addMultipartHandling pTag opts subserver =+addMultipartHandling pTag opts config subserver = addBodyCheck subserver contentCheck bodyCheck where contentCheck = withRequest $ \request ->- fuzzyMultipartCTCheck (contentTypeH request)+ unless (isFormContentType (contentTypeH request)) $+ liftRouteResult $ Fail $ withStatus unsupportedMediaType $ formatError request+ "the content type of the request body is not application/x-www-form-urlencoded or multipart/form-data" - bodyCheck () = do- mpd <- check pTag opts :: DelayedIO (MultipartData tag)- case (sbool :: SBool (FoldLenient mods), fromMultipart @tag @multipart mpd) of- (SFalse, Left msg) -> liftRouteResult $ FailFatal- err400 { errBody = "Could not decode multipart mime body: " <> cs msg }+ bodyCheck () = withRequest $ \ request -> do+ checked <- check pTag opts+ case (sbool :: SBool (FoldLenient mods), checked >>= first ParseError . fromMultipart @tag @multipart) of+ (SFalse, Left (ParseError msg)) -> liftRouteResult $ FailFatal $ formatError request msg+ (SFalse, Left (LimitError LimitExceeded {..})) ->+ liftRouteResult $ FailFatal $ withStatus statusOverride (formatError request limitMessage)+ (SFalse, Left (DecodeError InvalidUtf8 {..})) ->+ liftRouteResult $ FailFatal $ formatError request $+ part <> " of " <> kind <> " " <> show iname+ <> " is not valid UTF-8" (SFalse, Right x) -> return x- (STrue, res) -> return $ either (Left . cs) Right res+ (STrue, res) -> return res contentTypeH req = fromMaybe "application/octet-stream" $ lookup "Content-Type" (requestHeaders req) --- Check that the content type is one of:--- - application/x-www-form-urlencoded--- - multipart/form-data; boundary=something-fuzzyMultipartCTCheck :: SBS.ByteString -> DelayedIO ()-fuzzyMultipartCTCheck ct- | ctMatches = return ()- | otherwise = delayedFailFatal err400 {- errBody = "The content type of the request body is not in application/x-www-form-urlencoded or multipart/form-data"- }+ withStatus = maybe id $ \(code, phrase) err ->+ err { errHTTPCode = code, errReasonPhrase = phrase }+ defaultFormatError msg = err400 { errBody = "Could not decode multipart mime body: " <> TLE.encodeUtf8 (TL.pack msg) }+ pFormatters = Proxy :: Proxy ErrorFormatters+ rep = typeRep (Proxy :: Proxy MultipartForm')+ formatError request =+ case lookupContext pFormatters config of+ Nothing -> defaultFormatError+ Just fmts -> bodyParserErrorFormatter fmts rep request +isFormContentType :: SBS.ByteString -> Bool+isFormContentType ct =+ case ctype of+ "application/x-www-form-urlencoded" -> True+ "multipart/form-data" | Just _bound <- lookup "boundary" attrs -> True+ _ -> False where (ctype, attrs) = parseContentType ct- ctMatches = case ctype of- "application/x-www-form-urlencoded" -> True- "multipart/form-data" | Just _bound <- lookup "boundary" attrs -> True- _ -> False -- | Global options for configuring how the -- server should handle multipart data.@@ -485,55 +283,31 @@ -- See haddocks for 'ParseRequestBodyOptions' and -- 'TmpBackendOptions' respectively for more information on -- what you can tweak.+--+-- A form that exceeds one of the 'generalOptions' limits is rejected+-- before the handler runs, unless 'Servant.API.Modifiers.Lenient' is used,+-- in which case the handler is passed a 'LimitError'. The response is+-- built by the 'ErrorFormatters' in the context, if any, like other+-- request body errors, except that exceeding a size limit+-- always responds with status 413 and exceeding a part header limit+-- always responds with status 431. data MultipartOptions tag = MultipartOptions { generalOptions :: ParseRequestBodyOptions , backendOptions :: MultipartBackendOptions tag } -class MultipartBackend tag where- type MultipartResult tag :: *- type MultipartBackendOptions tag :: *-- backend :: Proxy tag- -> MultipartBackendOptions tag- -> InternalState- -> ignored1- -> ignored2- -> IO SBS.ByteString- -> IO (MultipartResult tag)-- loadFile :: Proxy tag -> MultipartResult tag -> SourceIO LBS.ByteString-- defaultBackendOptions :: Proxy tag -> MultipartBackendOptions tag---- | Tag for data stored as a temporary file-data Tmp---- | Tag for data stored in memory-data Mem- instance MultipartBackend Tmp where- type MultipartResult Tmp = FilePath type MultipartBackendOptions Tmp = TmpBackendOptions defaultBackendOptions _ = defaultTmpBackendOptions- -- streams the file from disk- loadFile _ fp =- SourceT $ \k ->- withFile fp ReadMode $ \hdl ->- k (readHandle hdl)- where- readHandle hdl = fromActionStep LBS.null (LBS.hGet hdl 4096) backend _ opts = tmpBackend where tmpBackend = tempFileBackEndOpts (getTmpDir opts) (filenamePat opts) instance MultipartBackend Mem where- type MultipartResult Mem = LBS.ByteString type MultipartBackendOptions Mem = () defaultBackendOptions _ = ()- loadFile _ = source . pure backend _ _ _ = lbsBackEnd -- | Configuration for the temporary file based backend.@@ -558,11 +332,26 @@ -- | Default configuration for multipart handling. ----- Uses 'defaultParseRequestBodyOptions' and--- 'defaultBackendOptions' respectively.+-- Uses 'defaultBackendOptions', and 'defaultParseRequestBodyOptions' with+-- a per-file size limit added. The per-file limit is set here, and the+-- others are the defaults of wai-extra 3.1.18. The resulting limits are:+--+-- * at most 25 MiB (@25 * 1024 * 1024@ bytes) per file+-- * at most 10 files+-- * no limit on the total size of all files+-- * at most 65336 bytes of textual inputs in total+-- * input and file input names of at most 32 bytes+-- * at most 32 header lines per part, each of at most 8190 bytes+--+-- Since the total size of all files is not limited, a single request can+-- carry up to 250 MiB of files, which the 'Mem' backend holds in memory+-- and the 'Tmp' backend writes to disk. Use 'setMaxRequestFileSize',+-- 'setMaxRequestFilesSize', 'setMaxRequestNumFiles' and the other setters+-- from "Network.Wai.Parse" on 'generalOptions' to change these limits, or+-- 'noLimitParseRequestBodyOptions' to remove them. defaultMultipartOptions :: MultipartBackend tag => Proxy tag -> MultipartOptions tag defaultMultipartOptions pTag = MultipartOptions- { generalOptions = defaultParseRequestBodyOptions+ { generalOptions = setMaxRequestFileSize (25 * 1024 * 1024) defaultParseRequestBodyOptions , backendOptions = defaultBackendOptions pTag } @@ -585,21 +374,13 @@ LookupContext cs a => LookupContext (a ': cs) a where lookupContext _ (c :. _) = Just c -instance HasLink sub => HasLink (MultipartForm tag a :> sub) where-#if MIN_VERSION_servant(0,14,0)- type MkLink (MultipartForm tag a :> sub) r = MkLink sub r- toLink toA _ = toLink toA (Proxy :: Proxy sub)-#else- type MkLink (MultipartForm tag a :> sub) = MkLink sub- toLink _ = toLink (Proxy :: Proxy sub)-#endif- -- | The 'ToMultipartSample' class allows you to create sample 'MultipartData' -- inputs for your type for use with "Servant.Docs". This is used by the -- 'HasDocs' instance for 'MultipartForm'. ----- Given the example 'User' type and 'FromMultipart' instance above, here is a--- corresponding 'ToMultipartSample' instance:+-- Given the example @User@ type and 'FromMultipart' instance from the+-- 'MultipartForm' documentation, here is a corresponding 'ToMultipartSample'+-- instance: -- -- @ -- data User = User { username :: Text, pic :: FilePath }@@ -662,17 +443,17 @@ toMultipartNotes maxSamples' proxyTag proxyA = let sampleLines = take maxSamples' $ toMultipartDescriptions proxyTag proxyA body =- [ "This endpoint takes `multipart/form-data` requests. The following is " <>- "a list of sample requests:"+ [ "This endpoint takes `multipart/form-data` requests. " <>+ "The following is a list of sample requests:" , foldMap (<> "\n") sampleLines ] in DocNote "Multipart Request Samples" $ fmap unpack body -- | Declare an instance of 'ToMultipartSample' for your 'MultipartForm' type -- to be able to use this 'HasDocs' instance.-instance (HasDocs api, ToMultipartSample tag a) => HasDocs (MultipartForm tag a :> api) where+instance (HasDocs api, ToMultipartSample tag a) => HasDocs (MultipartForm' mods tag a :> api) where docsFor- :: Proxy (MultipartForm tag a :> api)+ :: Proxy (MultipartForm' mods tag a :> api) -> (Endpoint, Action) -> DocOptions -> API@@ -688,8 +469,8 @@ in docsFor (Proxy :: Proxy api) (endpoint, newAction) opts instance (HasForeignType lang ftype a, HasForeign lang ftype api)- => HasForeign lang ftype (MultipartForm t a :> api) where- type Foreign ftype (MultipartForm t a :> api) = Foreign ftype api+ => HasForeign lang ftype (MultipartForm' mods t a :> api) where+ type Foreign ftype (MultipartForm' mods t a :> api) = Foreign ftype api foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy @api) $
test/Test.hs view
@@ -1,16 +1,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} import Data.ByteString as BS (ByteString)-import Data.ByteString.Lazy as BSL (ByteString)+import Data.ByteString.Lazy as BSL (ByteString, toStrict)+import qualified Data.ByteString.Lazy as BSL (replicate)+import qualified Data.ByteString.Lazy.Char8 as BSL8 (pack) import Data.List (intersperse) import Data.Monoid-import Data.String.Conversions (cs)-import Data.Text (Text)+import Data.Text (Text, pack)+import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Types.Header (HeaderName, hContentType)+import Network.Wai.Parse (defaultParseRequestBodyOptions, setMaxRequestFileSize) import Test.Tasty import Test.Tasty.Wai@@ -32,6 +36,26 @@ , testGroup "strict handler with raw MultipartData" [ testWai testApp "correct body" testBlogPostRawHandler ]+ , testGroup "form limits"+ [ testWai testApp "field name too long" testFieldNameTooLong+ , testWai testApp "too many files" testTooManyFiles+ , testWai testApp "too many files with lenient handler" testTooManyFilesLenient+ , testWai testApp "part header line too long" testPartHeaderLineTooLong+ , testWai testApp "too many part header lines" testTooManyPartHeaderLines+ , testWai limitedApp "file under size limit" testFileUnderSizeLimit+ , testWai limitedApp "file over size limit" testFileOverSizeLimit+ ]+ , testGroup "form limits with custom ErrorFormatters"+ [ testWai customFormatterApp "too many files keeps formatter status" testTooManyFilesCustomFormatter+ , testWai customFormatterApp "file over size limit is 413" testFileOverSizeLimitCustomFormatter+ , testWai customFormatterApp "unsupported content type is 415" testUnsupportedContentTypeCustomFormatter+ ]+ , testGroup "content type"+ [ testWai testApp "unsupported content type" testUnsupportedContentType+ , testWai testApp "multipart without boundary" testMultipartWithoutBoundary+ , testWai alternativeApp "unsupported content type falls through to later route" testUnsupportedContentTypeFallsThrough+ , testWai alternativeApp "multipart request matches multipart route" testMultipartBeforeAlternative+ ] ] data BlogPost@@ -44,30 +68,58 @@ fromMultipart md = BlogPost <$> lookupInput "title" md- <*> fmap (cs . fdPayload) (lookupFile "body" md)+ <*> fmap (decodeUtf8 . BSL.toStrict . fdPayload) (lookupFile "body" md) type TestAPI = "blogPostStrict" :> MultipartForm Mem BlogPost :> Post '[PlainText] Text- :<|> "blogPostLenient" :> MultipartForm' '[Lenient] Mem BlogPost :> Post '[JSON] Bool+ :<|> "blogPostLenient" :> MultipartForm' '[Lenient] Mem BlogPost :> Post '[PlainText] Text :<|> "blogPostRaw" :> MultipartForm Mem (MultipartData Mem) :> Post '[PlainText] Text blogPostStrictHandler :: BlogPost -> Handler Text blogPostStrictHandler bp = return $ title bp <> "\n" <> body bp -blogPostLenientHandler :: Either String BlogPost -> Handler Bool+blogPostLenientHandler :: Either CheckError BlogPost -> Handler Text blogPostLenientHandler eitherBP =- case eitherBP of- Left _ -> return False- Right _ -> return True+ return $ case eitherBP of+ Left (ParseError msg) -> "parse error: " <> pack msg+ Left (LimitError limit) -> "limit exceeded: " <> pack (limitMessage limit)+ Left (DecodeError InvalidUtf8 {..}) -> "decoding error: " <> pack (part <> " of " <> kind <> " " <> show iname <> " is not valid UTF-8")+ Right bp -> title bp blogPostRawHandler :: MultipartData Mem -> Handler Text blogPostRawHandler md = return $ mconcat $ intersperse " " $ map iName (inputs md) <> map fdInputName (files md) +testServer :: Server TestAPI+testServer = blogPostStrictHandler :<|> blogPostLenientHandler :<|> blogPostRawHandler+ testApp :: Application-testApp = serve @TestAPI Proxy $ blogPostStrictHandler :<|> blogPostLenientHandler :<|> blogPostRawHandler+testApp = serve @TestAPI Proxy testServer +limitedOptions :: MultipartOptions Mem+limitedOptions = (defaultMultipartOptions (Proxy @Mem))+ { generalOptions = setMaxRequestFileSize 100 defaultParseRequestBodyOptions }++limitedApp :: Application+limitedApp = serveWithContext @TestAPI Proxy (limitedOptions :. EmptyContext) testServer++customFormatterApp :: Application+customFormatterApp =+ serveWithContext @TestAPI Proxy (limitedOptions :. customFormatters :. EmptyContext) testServer+ where+ customFormatters = defaultErrorFormatters+ { bodyParserErrorFormatter = \_ _ msg -> err422 { errBody = "custom: " <> BSL8.pack msg } }++type AlternativeAPI+ = "upload" :> MultipartForm Mem (MultipartData Mem) :> Post '[PlainText] Text+ :<|> "upload" :> ReqBody '[PlainText] Text :> Post '[PlainText] Text++alternativeApp :: Application+alternativeApp =+ serve @AlternativeAPI Proxy $+ blogPostRawHandler :<|> (\txt -> return $ "plain text: " <> txt)+ multipartHeaders :: [(HeaderName, BS.ByteString)] multipartHeaders = [(hContentType, "multipart/form-data; boundary=XX")] @@ -93,13 +145,13 @@ testBlogPostLenientHandler = do res <- srequest $ buildRequestWithHeaders POST "/blogPostLenient" correctBody multipartHeaders assertStatus 200 res- assertBody "true" res+ assertBody "Foo post" res testBlogPostLenientHandlerPartialBody :: Session () testBlogPostLenientHandlerPartialBody = do res <- srequest $ buildRequestWithHeaders POST "/blogPostLenient" partialBody multipartHeaders assertStatus 200 res- assertBody "false" res+ assertBody "parse error: File body not found" res testBlogPostRawHandler :: Session () testBlogPostRawHandler = do@@ -130,3 +182,109 @@ , "" , "--XX--" ]++testFieldNameTooLong :: Session ()+testFieldNameTooLong = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" (formBody [fieldPart (BSL.replicate 33 0x61)]) multipartHeaders+ assertStatus 400 res+ assertBody "Could not decode multipart mime body: an input name exceeds 32 bytes" res++testTooManyFiles :: Session ()+testTooManyFiles = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" elevenFiles multipartHeaders+ assertStatus 400 res+ assertBody "Could not decode multipart mime body: the form has more than 10 files" res++testTooManyFilesLenient :: Session ()+testTooManyFilesLenient = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostLenient" elevenFiles multipartHeaders+ assertStatus 200 res+ assertBody "limit exceeded: the form has more than 10 files" res++testPartHeaderLineTooLong :: Session ()+testPartHeaderLineTooLong = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" (formBody [fieldPart (BSL.replicate 9000 0x61)]) multipartHeaders+ assertStatus 431 res+ assertBody "Could not decode multipart mime body: a part header line exceeds the length limit" res++testTooManyPartHeaderLines :: Session ()+testTooManyPartHeaderLines = do+ let manyHeaders = "--XX" : replicate 40 "X-Extra: 1" <> drop 1 (fieldPart "title")+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" (formBody [manyHeaders]) multipartHeaders+ assertStatus 431 res+ assertBody "Could not decode multipart mime body: a part has too many header lines" res++testFileUnderSizeLimit :: Session ()+testFileUnderSizeLimit = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" (formBody [filePart "file" (BSL.replicate 20 0x78)]) multipartHeaders+ assertStatus 200 res+ assertBody "file" res++testFileOverSizeLimit :: Session ()+testFileOverSizeLimit = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" (formBody [filePart "file" (BSL.replicate 200 0x78)]) multipartHeaders+ assertStatus 413 res+ assertBody "Could not decode multipart mime body: the form exceeds a size limit" res++testTooManyFilesCustomFormatter :: Session ()+testTooManyFilesCustomFormatter = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" elevenFiles multipartHeaders+ assertStatus 422 res+ assertBody "custom: the form has more than 10 files" res++testFileOverSizeLimitCustomFormatter :: Session ()+testFileOverSizeLimitCustomFormatter = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" (formBody [filePart "file" (BSL.replicate 200 0x78)]) multipartHeaders+ assertStatus 413 res+ assertBody "custom: the form exceeds a size limit" res++testUnsupportedContentType :: Session ()+testUnsupportedContentType = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" correctBody [(hContentType, "application/json")]+ assertStatus 415 res+ assertBody "Could not decode multipart mime body: the content type of the request body is not application/x-www-form-urlencoded or multipart/form-data" res++testMultipartWithoutBoundary :: Session ()+testMultipartWithoutBoundary = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" correctBody [(hContentType, "multipart/form-data")]+ assertStatus 415 res++testUnsupportedContentTypeCustomFormatter :: Session ()+testUnsupportedContentTypeCustomFormatter = do+ res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" correctBody [(hContentType, "application/json")]+ assertStatus 415 res+ assertBody "custom: the content type of the request body is not application/x-www-form-urlencoded or multipart/form-data" res++testUnsupportedContentTypeFallsThrough :: Session ()+testUnsupportedContentTypeFallsThrough = do+ res <- srequest $ buildRequestWithHeaders POST "/upload" "hello" [(hContentType, "text/plain;charset=utf-8")]+ assertStatus 200 res+ assertBody "plain text: hello" res++testMultipartBeforeAlternative :: Session ()+testMultipartBeforeAlternative = do+ res <- srequest $ buildRequestWithHeaders POST "/upload" correctBody multipartHeaders+ assertStatus 200 res+ assertBody "title body" res++elevenFiles :: BSL.ByteString+elevenFiles = formBody (replicate 11 (filePart "file" "contents"))++fieldPart :: BSL.ByteString -> [BSL.ByteString]+fieldPart name =+ [ "--XX"+ , "Content-Disposition: form-data; name=\"" <> name <> "\""+ , ""+ , "value"+ ]++filePart :: BSL.ByteString -> BSL.ByteString -> [BSL.ByteString]+filePart name contents =+ [ "--XX"+ , "Content-Disposition: form-data; name=\"" <> name <> "\"; filename=\"file.txt\""+ , ""+ , contents+ ]++formBody :: [[BSL.ByteString]] -> BSL.ByteString+formBody parts = mconcat $ intersperse "\n" (concat parts <> ["--XX--"])