diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------ diff --git a/servant-multipart.cabal b/servant-multipart.cabal --- a/servant-multipart.cabal +++ b/servant-multipart.cabal @@ -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 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 #-} @@ -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) $ 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--"])