servant-multipart 0.12.1 → 0.13.0

raw patch · 4 files changed

+401/−115 lines, 4 filesdep +deepseqdep +warpdep −string-conversionsdep ~basedep ~bytestringdep ~resourcetnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, warp

Dependencies removed: string-conversions

Dependency ranges changed: base, bytestring, resourcet, servant, servant-docs, servant-foreign, servant-multipart-api, servant-server, text, wai, wai-extra

API changes (from Hackage documentation)

Files

• CHANGELOG.md +39/−0
• servant-multipart.cabal +22/−16
• src/Servant/Multipart.hs +170/−87
• test/Test.hs +170/−12

@@ -1,3 +1,42 @@+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 ------ 

@@ -1,5 +1,5 @@ name:               servant-multipart-version:            0.12.1+version:            0.13.0 synopsis:           multipart/form-data (e.g file upload) support for servant description:   This package adds server-side support of file upload to the servant ecosystem.@@ -14,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.4 || ==8.10.4+tested-with:+  GHC ==9.4.8+   || ==9.6.3+   || ==9.8.4+   || ==9.10.3+   || ==9.12.4  library   default-language: Haskell2010@@ -23,23 +28,24 @@    -- ghc boot libs   build-depends:-      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+    , text          >=2.0      && <2.2    -- other dependencies   build-depends:-      servant-multipart-api == 0.12.*-    , lens                >=4.17     && <5.1-    , resourcet           >=1.2.2    && <1.3-    , servant             >=0.16     && <0.19-    , servant-docs        >=0.10     && <0.19-    , servant-foreign     >=0.15     && <0.19-    , servant-server      >=0.16     && <0.19-    , string-conversions  >=0.4.0.1  && <0.5-    , wai                 >=3.2.1.2  && <3.3-    , wai-extra           >=3.0.24.3 && <3.2+      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@@ -52,10 +58,10 @@     , http-types     , servant-multipart     , servant-server-    , string-conversions     , tasty     , tasty-wai     , text+    , wai-extra  source-repository head   type:     git

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}@@ -23,6 +22,13 @@   , FromMultipart(..)   , lookupInput   , lookupFile+  , lookupAllInputs+  , lookupAllFiles +  , lookupInputAs +  , lookupAllInputsAs +  , CheckError(..)+  , LimitExceeded(..)+  , InvalidUtf8(..)   , MultipartOptions(..)   , defaultMultipartOptions   , MultipartBackend(..)@@ -34,23 +40,23 @@   , FileData(..)   -- * servant-docs   , ToMultipartSample(..)+  , LookupContext(..)   ) where  import Servant.Multipart.API +import Control.DeepSeq (NFData (rnf)) import Control.Lens ((<>~), (&), view, (.~))+import Control.Monad (unless) import Control.Monad.IO.Class import Control.Monad.Trans.Resource-import Data.List (find)+import Data.Bifunctor (first) import Data.Maybe-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif-import Data.String.Conversions (cs) import Data.Text (Text, unpack)-import Data.Text.Encoding (decodeUtf8)+import Data.Text.Encoding (decodeUtf8') import Data.Typeable import Network.Wai+import Network.Wai.Handler.Warp (InvalidRequest (PayloadTooLarge, RequestHeaderFieldsTooLarge)) import Network.Wai.Parse import Servant hiding (contentType) import Servant.API.Modifiers (FoldLenient)@@ -59,38 +65,37 @@ import Servant.Server.Internal import System.Directory -import qualified Data.ByteString      as SBS---- | 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---- | 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+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)+          FileData <$> decFile "name" iname iname+                   <*> decFile "file name" iname (fileName fileinfo)+                   <*> decFile "content type" iname (fileContentType fileinfo)+                   <*> pure (fileContent fileinfo) -        dec = decodeUtf8+        decInput = dec "input"+        decFile  = dec "file input" +        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+ class MultipartBackend tag where     type MultipartBackendOptions tag :: * @@ -107,23 +112,21 @@ -- | 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)-#if MIN_VERSION_servant_server(0,18,0)          , LookupContext config ErrorFormatters-#endif          , 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'@@ -135,81 +138,137 @@                     $ lookupContext popts config       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 :: [*]) config env a.                      ( FromMultipart tag multipart                      , MultipartBackend tag-#if MIN_VERSION_servant_server(0,18,0)                      , LookupContext config ErrorFormatters-#endif                      )                      => SBoolI (FoldLenient mods)                      => Proxy tag                      -> MultipartOptions tag                      -> Context config-                     -> Delayed env (If (FoldLenient mods) (Either String multipart) multipart -> a)+                     -> Delayed env (If (FoldLenient mods) (Either CheckError multipart) multipart -> a)                      -> Delayed env a-addMultipartHandling pTag opts _config 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 () = withRequest $ \ request -> do-      mpd <- check pTag opts :: DelayedIO (MultipartData tag)-      case (sbool :: SBool (FoldLenient mods), fromMultipart @tag @multipart mpd) of-        (SFalse, Left msg) -> liftRouteResult $ FailFatal $ formatError request msg+      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) -    defaultFormatError msg = err400 { errBody = "Could not decode multipart mime body: " <> cs msg }-#if MIN_VERSION_servant_server(0,18,0)+    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+      case lookupContext pFormatters config of         Nothing -> defaultFormatError         Just fmts -> bodyParserErrorFormatter fmts rep request-#else-    formatError _ = defaultFormatError-#endif --- 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"-      }-+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.@@ -224,6 +283,14 @@ --   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@@ -265,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   } @@ -296,8 +378,9 @@ -- 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 }@@ -368,9 +451,9 @@  -- | 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@@ -386,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) $

@@ -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--"])