diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------ diff --git a/exe/Upload.hs b/exe/Upload.hs deleted file mode 100644 --- a/exe/Upload.hs +++ /dev/null @@ -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" - ] diff --git a/servant-multipart.cabal b/servant-multipart.cabal --- a/servant-multipart.cabal +++ b/servant-multipart.cabal @@ -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 diff --git a/src/Servant/Multipart.hs b/src/Servant/Multipart.hs --- a/src/Servant/Multipart.hs +++ b/src/Servant/Multipart.hs @@ -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 @\@. --- --- @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 @\@ --- 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 --- @\@. -data FileData tag = FileData - { fdInputName :: Text -- ^ @name@ attribute of the corresponding - -- HTML @\@ - , 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 @\@ type but @file@). --- --- @\@ 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) $ diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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--"])