wai-middleware-validation (empty) → 0.1.0.0
raw patch · 11 files changed
+1627/−0 lines, 11 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, doctest, filepath, here, hspec, http-types, insert-ordered-containers, lens, openapi3, text, wai, wai-extra, wai-middleware-validation
Files
- ChangeLog.md +5/−0
- LICENSE +29/−0
- README.md +41/−0
- Setup.hs +2/−0
- src/Network/Wai/Middleware/Validation.hs +167/−0
- src/Network/Wai/Middleware/Validation/Internal.hs +192/−0
- test/Network/Wai/Middleware/Validation/InternalSpec.hs +266/−0
- test/Network/Wai/Middleware/ValidationSpec.hs +852/−0
- test/Spec.hs +1/−0
- test/doctest/doctest-driver.hs +9/−0
- wai-middleware-validation.cabal +63/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for wai-middleware-validation++## 0.1.0.0 (2021-03-17)++- Initial release.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2021, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,41 @@+# wai-middleware-validation [](https://app.circleci.com/pipelines/github/iij-ii/wai-middleware-validation)++wai-middleware-validation is a WAI Middleware that automates the validation of request and response bodies. It validates JSON format bodies according to the schema defined in the OpenAPI document.++## Usage++The following is an example of applying it to a Yesod application.++1. Define the request and response specifications as an OpenAPI document file in JSON format and place it in an arbitrary path. (In this case, we will use "config/openapi.json".)+2. Make the following modifications to `Application.hs`.+```diff+--- a/src/Application.hs++++ b/src/Application.hs+@@ -37,6 +37,8 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),+ mkRequestLogger, outputFormat)+ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,+ toLogStr)++import Network.Wai.Middleware.Validation (mkValidator')++import qualified Data.ByteString.Lazy as L++ -- Import all relevant handler modules here.+ -- Don't forget to add new modules to your cabal file!+@@ -94,7 +97,10 @@ makeApplication foundation = do+ logWare <- makeLogWare foundation+ -- Create the WAI application and apply middlewares+ appPlain <- toWaiAppPlain foundation+- return $ logWare $ defaultMiddlewaresNoLogging appPlain++ apiJson <- L.readFile "config/openapi.json"++ let validator = fromMaybe (error "Invalid OpenAPI document") (mkValidator' apiJson)++ app = validator appPlain++ return $ logWare $ defaultMiddlewaresNoLogging app++ makeLogWare :: App -> IO Middleware+ makeLogWare foundation =+```++## LICENCE++Copyright (c) IIJ Innovation Institute Inc.++Licensed under The 3-Clause BSD License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Network/Wai/Middleware/Validation.hs view
@@ -0,0 +1,167 @@+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Network.Wai.Middleware.Validation where++import Data.Aeson (ToJSON, encode, object, toJSON, (.=))+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import Data.IORef (atomicModifyIORef, newIORef, readIORef)+import Network.HTTP.Types (ResponseHeaders, StdMethod,+ badRequest400, hContentType,+ internalServerError500, parseMethod,+ statusCode, statusIsSuccessful)+import Network.Wai (Middleware, Request, Response,+ rawPathInfo, requestBody,+ requestMethod, responseLBS,+ responseStatus, responseToStream,+ strictRequestBody)++import Network.Wai.Middleware.Validation.Internal (ApiDefinition, getRequestBodySchema,+ getResponseBodySchema, toApiDefinition,+ validateJsonDocument)+++data DefaultErrorJson = DefaultErrorJson+ { title :: String+ , detail :: String+ } deriving (Show)++instance ToJSON DefaultErrorJson where+ toJSON (DefaultErrorJson t d) = object ["title" .= t, "detail" .= d]++-- | Make error string with JSON.+mkDefaultErrorJson :: String -> DefaultErrorJson+mkDefaultErrorJson = DefaultErrorJson "Validation failed"+++-- | Make a middleware for Request/Response validation.+mkValidator' :: L.ByteString -> Maybe Middleware+mkValidator' = mkValidator mkDefaultErrorJson++mkValidator :: ToJSON a => (String -> a) -> L.ByteString -> Maybe Middleware+mkValidator mkErrorJson apiJson = (.) <$> mResValidator <*> mReqValidator+ where+ mApiDef = toApiDefinition apiJson+ mReqValidator = requestValidator mkErrorJson <$> mApiDef+ mResValidator = responseValidator mkErrorJson <$> mApiDef++-- | Make a middleware for Requestion validation.+mkRequestValidator' :: L.ByteString -> Maybe Middleware+mkRequestValidator' = mkRequestValidator mkDefaultErrorJson++mkRequestValidator :: ToJSON a => (String -> a) -> L.ByteString -> Maybe Middleware+mkRequestValidator mkErrorJson apiJson = requestValidator mkErrorJson <$> toApiDefinition apiJson++-- | Make a middleware for Response validation.+mkResponseValidator' :: L.ByteString -> Maybe Middleware+mkResponseValidator' = mkResponseValidator mkDefaultErrorJson++mkResponseValidator :: ToJSON a => (String -> a) -> L.ByteString -> Maybe Middleware+mkResponseValidator mkErrorJson apiJson = responseValidator mkErrorJson <$> toApiDefinition apiJson++requestValidator :: ToJSON a => (String -> a) -> ApiDefinition -> Middleware+requestValidator mkErrorJson apiDef app req sendResponse = do+ let+ eMethod = parseMethod $ requestMethod req+ path = S8.unpack $ rawPathInfo req+ mBodySchema = case eMethod of+ Right method -> getRequestBodySchema apiDef method path+ _ -> Nothing++ putStrLn ">>> [Request]"+ putStrLn $ ">>> Method: " ++ show eMethod+ putStrLn $ ">>> Path: " ++ path++ case mBodySchema of+ Nothing -> app req sendResponse+ Just bodySchema -> do+ (body, newReq) <- getRequestBody req+ putStrLn $ ">>> Body: " ++ show body++ case validateJsonDocument apiDef bodySchema body of+ Right [] -> app newReq sendResponse+ Right errs -> respondError $ unlines errs+ Left err -> respondError err+ where+ respondError msg = sendResponse $+ responseLBS badRequest400 [(hContentType, "application/json")] $ encode $ mkErrorJson msg++responseValidator :: ToJSON a => (String -> a) -> ApiDefinition -> Middleware+responseValidator mkErrorJson apiDef app req sendResponse = app req $ \res -> do+ let status = responseStatus res+ -- Validate only the success response.+ if statusIsSuccessful status+ then do+ let+ eMethod = parseMethod $ requestMethod req+ path = S8.unpack $ rawPathInfo req+ statusCode' = statusCode status+ mBodySchema = case eMethod of+ Right method -> getResponseBodySchema apiDef method path statusCode'+ _ -> Nothing++ putStrLn ">>> [Response]"+ putStrLn $ ">>> Method: " ++ show eMethod+ putStrLn $ ">>> Path: " ++ path+ putStrLn $ ">>> Status: " ++ show statusCode'++ case mBodySchema of+ Nothing -> sendResponse res+ Just bodySchema -> do+ body <- getResponseBody res+ putStrLn $ ">>> Body': " ++ show body++ case validateJsonDocument apiDef bodySchema body of+ Right [] -> sendResponse res+ -- REVIEW: It may be better not to include the error details in the response.+ -- _ -> respondError "Invalid response body"+ Right errs -> respondError $ unlines errs+ Left err -> respondError err++ else sendResponse res+ where+ respondError msg = sendResponse $+ responseLBS internalServerError500 [(hContentType, "application/json")] $ encode $ mkErrorJson msg++getRequestBody :: Request -> IO (L.ByteString, Request)+getRequestBody req = do+ body <- strictRequestBody req+ -- The body has been consumed and needs to be refilled.+ ref <- newIORef body+ let newRequestBody = atomicModifyIORef ref (L.empty,)+ let newReq = req { requestBody = L.toStrict <$> newRequestBody }+ return (body, newReq)++getResponseBody :: Response -> IO L.ByteString+getResponseBody res = do+ let (_, _, withBody) = responseToStream res+ withBody $ \streamingBody -> do+ ref <- newIORef mempty+ streamingBody+ (\b -> atomicModifyIORef ref $ \acc -> (acc <> b, ()))+ (pure ())+ toLazyByteString <$> readIORef ref++responseHeaders :: ResponseHeaders+responseHeaders = [(hContentType, "application/json")]++--+-- for non-middleware use+--++validateRequestBody :: StdMethod -> FilePath -> L.ByteString -> L.ByteString -> Either String [String]+validateRequestBody method path apiJson body = case toApiDefinition apiJson of+ Nothing -> Left "Invalid OpenAPI document"+ Just apiDef -> case getRequestBodySchema apiDef method path of+ Nothing -> Left "Schema not found"+ Just bodySchema -> validateJsonDocument apiDef bodySchema body++validateResponseBody :: StdMethod -> FilePath -> Int -> L.ByteString -> L.ByteString -> Either String [String]+validateResponseBody method path statusCode' apiJson body = case toApiDefinition apiJson of+ Nothing -> Left "Invalid OpenAPI document"+ Just apiDef -> case getResponseBodySchema apiDef method path statusCode' of+ Nothing -> Left "Schema not found"+ Just bodySchema -> validateJsonDocument apiDef bodySchema body
+ src/Network/Wai/Middleware/Validation/Internal.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.Validation.Internal where++import Control.Lens (at, (^.), (^?), _Just)+import Data.Aeson (Value, decode)+import qualified Data.ByteString.Lazy as L+import Data.HashMap.Strict.InsOrd (InsOrdHashMap, keys)+import qualified Data.Map.Strict as M+import Data.OpenApi (HttpStatusCode, OpenApi, Operation, PathItem,+ Referenced, Schema, components, content, default_,+ paths, requestBodies, requestBody, responses,+ schema, schemas, validateJSON, _pathItemDelete,+ _pathItemGet, _pathItemPatch, _pathItemPost,+ _pathItemPut)+import Data.OpenApi.Schema.Generator (dereference)+import qualified Data.Text as T+import Network.HTTP.Types (StdMethod (DELETE, GET, PATCH, POST, PUT))+import System.FilePath (splitDirectories)++--+-- For reverse look up of path+-- https://swagger.io/specification/#path-templating-matching+--++data TemplatedPathComponent = Exact FilePath | ParameterValue deriving (Show)++instance Eq TemplatedPathComponent where+ Exact l == Exact r = l == r+ _ == _ = True++instance Ord TemplatedPathComponent where+ compare (Exact l) (Exact r) = compare l r+ compare _ _ = EQ++-- | Convert FilePath to TemplatedPathComponent.+--+-- >>> toTemplatedPathComponent "foo"+-- Exact "foo"+-- >>> toTemplatedPathComponent "{foo}"+-- ParameterValue+toTemplatedPathComponent :: FilePath -> TemplatedPathComponent+toTemplatedPathComponent s+ | not (null s) && head s == '{' && last s == '}' = ParameterValue+ | otherwise = Exact s++type TemplatedPath = [TemplatedPathComponent]++-- | Convert FilePath to TemplatedPath.+--+-- >>> toTemplatedPath "/foo/{fooId}"+-- [Exact "/",Exact "foo",ParameterValue]+-- >>> toTemplatedPath "/bar/{barId}/baz/{bazId}"+-- [Exact "/",Exact "bar",ParameterValue,Exact "baz",ParameterValue]+toTemplatedPath :: FilePath -> TemplatedPath+toTemplatedPath p = map toTemplatedPathComponent $ splitDirectories p++type PathMap = M.Map TemplatedPath FilePath++-- | Convert list of FilePath to PathMap.+--+-- >>> makePathMap ["/foo", "/foo/{fooId}"]+-- fromList [([Exact "/",Exact "foo"],"/foo"),([Exact "/",Exact "foo",ParameterValue],"/foo/{fooId}")]+makePathMap :: [FilePath] -> PathMap+makePathMap ps = M.fromList $ zip (map toTemplatedPath ps) ps++-- | Look up a path (including a templated path) from PathMap.+--+-- >>> lookupDefinedPath "/foo" (makePathMap ["/foo", "/foo/{fooId}"])+-- Just "/foo"+-- >>> lookupDefinedPath "/foo/1" (makePathMap ["/foo", "/foo/{fooId}"])+-- Just "/foo/{fooId}"+-- >>> lookupDefinedPath "/bar" (makePathMap ["/foo", "/foo/{fooId}"])+-- Nothing+lookupDefinedPath :: FilePath -> PathMap -> Maybe FilePath+lookupDefinedPath realPath = M.lookup (toTemplatedPath realPath)+++data ApiDefinition = ApiDefinition+ { getOpenApi :: OpenApi+ , getPathMap :: PathMap+ } deriving (Eq, Show)++-- | Create ApiDefinition instance from API document.+--+toApiDefinition :: L.ByteString -> Maybe ApiDefinition+toApiDefinition openApiJson = ApiDefinition <$> mOpenApi <*> mPathMap+ where+ mOpenApi = decode openApiJson :: Maybe OpenApi+ mKeys = keys <$> (mOpenApi ^? _Just . paths)+ mPathMap = case mKeys of+ -- OpenAPI Object must have `paths`+ -- https://swagger.io/specification/#openapi-object+ Just [] -> Nothing+ _ -> makePathMap <$> mKeys+++newtype BodySchema = BodySchema { toReferencedSchema :: Referenced Schema } deriving (Eq, Show)++-- | Get request body schema.+--+getRequestBodySchema :: ApiDefinition -> StdMethod -> FilePath -> Maybe BodySchema+getRequestBodySchema a DELETE p = BodySchema <$> getRequestBodyReferencedSchema a _pathItemDelete p+getRequestBodySchema a GET p = BodySchema <$> getRequestBodyReferencedSchema a _pathItemGet p+getRequestBodySchema a PATCH p = BodySchema <$> getRequestBodyReferencedSchema a _pathItemPatch p+getRequestBodySchema a POST p = BodySchema <$> getRequestBodyReferencedSchema a _pathItemPost p+getRequestBodySchema a PUT p = BodySchema <$> getRequestBodyReferencedSchema a _pathItemPut p+getRequestBodySchema _ _ _ = Nothing++getRequestBodyReferencedSchema :: ApiDefinition -> (PathItem -> Maybe Operation) -> FilePath -> Maybe (Referenced Schema)+getRequestBodyReferencedSchema apiDef pathItemMethod realPath =+ let+ openApi = getOpenApi apiDef+ mDefinitionsRequestBody = openApi ^? components . requestBodies+ mOperation = getPathItem apiDef realPath >>= pathItemMethod+ mReferencedRequestBody = mOperation ^? _Just . requestBody . _Just+ mRequestBody = dereference <$> mDefinitionsRequestBody <*> mReferencedRequestBody+ mReferencedSchema = mRequestBody ^? _Just . content . at "application/json" . _Just . schema . _Just+ in+ mReferencedSchema++-- | Get response body schema.+--+getResponseBodySchema :: ApiDefinition -> StdMethod -> FilePath -> Int -> Maybe BodySchema+getResponseBodySchema a DELETE p s = BodySchema <$> getResponseBodyReferencedSchema a _pathItemDelete p s+getResponseBodySchema a GET p s = BodySchema <$> getResponseBodyReferencedSchema a _pathItemGet p s+getResponseBodySchema a PATCH p s = BodySchema <$> getResponseBodyReferencedSchema a _pathItemPatch p s+getResponseBodySchema a POST p s = BodySchema <$> getResponseBodyReferencedSchema a _pathItemPost p s+getResponseBodySchema a PUT p s = BodySchema <$> getResponseBodyReferencedSchema a _pathItemPut p s+getResponseBodySchema _ _ _ _ = Nothing++getResponseBodyReferencedSchema :: ApiDefinition -> (PathItem -> Maybe Operation) -> FilePath -> Int -> Maybe (Referenced Schema)+getResponseBodyReferencedSchema apiDef pathItemMethod realPath statusCode =+ let+ openApi = getOpenApi apiDef+ mDefinitionsResponse = openApi ^? components . responses+ mOperation = getPathItem apiDef realPath >>= pathItemMethod+ mResponses = mOperation ^? _Just . responses+ mReferencedResponse = case mResponses ^? _Just . at statusCode . _Just of+ Just rr -> Just rr+ Nothing -> mResponses ^? _Just . default_ . _Just+ mResponse = dereference <$> mDefinitionsResponse <*> mReferencedResponse+ mReferencedSchema = mResponse ^? _Just . content . at "application/json" . _Just . schema . _Just+ in+ mReferencedSchema++getPathItem :: ApiDefinition -> FilePath -> Maybe PathItem+getPathItem apiDef realPath = mPath >>= \definedPath -> openApi ^? paths . at definedPath . _Just+ where+ openApi = getOpenApi apiDef+ mPath = lookupDefinedPath realPath $ getPathMap apiDef+++-- | Validate JSON document.+--+validateJsonDocument :: ApiDefinition -> BodySchema -> L.ByteString -> Either String [String]+validateJsonDocument apiDef bodySchema dataJson = case decode dataJson :: Maybe Value of+ Nothing -> Left "The document is not JSON."+ Just val -> case definitionsSchema' of+ Nothing -> Left "Schema objects are not defined in the OpenAPI document."+ Just ds -> case schema' of+ Nothing -> Left "The schema for the data is not defined in the OpenAPI document."+ Just s -> Right $ map fixValidationError $ validateJSON ds s val+ where+ openApi = getOpenApi apiDef+ definitionsSchema' = openApi ^? components . schemas+ referencedSchema' = toReferencedSchema bodySchema+ schema' = (`dereference` referencedSchema') <$> definitionsSchema'++-- | Fix validation error message.+--+-- >>> fixValidationError "Hello, World!"+-- "Hello, World!"+-- >>> fixValidationError "expected JSON value of type OpenApiString"+-- "expected JSON value of type string"+-- >>> fixValidationError "expected JSON value of type OpenApiNumber"+-- "expected JSON value of type number"+-- >>> fixValidationError "expected JSON value of type OpenApiInteger"+-- "expected JSON value of type integer"+-- >>> fixValidationError "expected JSON value of type OpenApiBoolean"+-- "expected JSON value of type boolean"+fixValidationError :: String -> String+fixValidationError msg = T.unpack $ foldr replace' (T.pack msg) replacements+ where+ replace' (needle, replacement) = T.replace needle replacement+ replacements =+ -- replace internal type name with OpenAPI standard type name+ [ ("OpenApiString", "string")+ , ("OpenApiNumber", "number")+ , ("OpenApiInteger", "integer")+ , ("OpenApiBoolean", "boolean")+ ]
+ test/Network/Wai/Middleware/Validation/InternalSpec.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Network.Wai.Middleware.Validation.InternalSpec (spec) where++import Data.ByteString.Lazy as L+import Data.Either (isLeft)+import Data.Maybe (fromJust, isJust)+import Data.OpenApi+import Data.String.Here (here)+import Network.HTTP.Types (StdMethod (GET, POST, PUT))+import Test.Hspec++import Network.Wai.Middleware.Validation.Internal+++openApiJson :: L.ByteString+openApiJson = [here|+{+ "openapi": "3.0.0",+ "info": { "title": "validator test", "version": "1.0.0" },+ "paths": {+ "/articles": {+ "get": {+ "responses": {+ "200": {+ "description": "OK",+ "content": {+ "application/json": {+ "schema": {+ "type": "array",+ "items": {+ "$ref": "#/components/schemas/Article"+ }+ }+ }+ }+ }+ }+ },+ "post": {+ "requestBody": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/Article"+ }+ }+ }+ },+ "responses": { "default": { "description": "response example" } }+ }+ },+ "/articles/{articleId}": {+ "parameters": [+ {+ "name": "articleId",+ "in": "path",+ "required": true,+ "schema": { "type": "integer" }+ }+ ],+ "put": {+ "requestBody": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/Article"+ }+ }+ }+ },+ "responses": { "default": { "description": "response example" } }+ }+ }+ },+ "components": {+ "schemas": {+ "Article": {+ "type": "object",+ "required": [ "cint", "ctxt" ],+ "properties": {+ "cint": { "type": "integer" },+ "ctxt": { "type": "string" }+ }+ }+ }+ }+}+|]++apiDef :: ApiDefinition+apiDef = fromJust $ toApiDefinition openApiJson++postRequestBodySchema :: BodySchema+postRequestBodySchema = fromJust $ getRequestBodySchema apiDef POST "/articles"++putRequestBodySchema :: BodySchema+putRequestBodySchema = fromJust $ getRequestBodySchema apiDef PUT "/articles/1"++-- postResponseBodySchema :: BodySchema+-- postResponseBodySchema = fromJust $ getPostResponseBodySchema apiDef "/articles" 200++-- putResponseBodySchema :: BodySchema+-- putResponseBodySchema = fromJust $ getPutResponseBodySchema apiDef "/articles/1" 200++spec :: Spec+spec = do+ describe "toApiDefinition" $ do+ it "returns Just ApiDefinition if the OpenAPI document is valid" $+ toApiDefinition openApiJson `shouldSatisfy` isJust++ it "returns Nothing if the OpenAPI document is invalid" $+ toApiDefinition "" `shouldBe` Nothing++ it "returns Nothing if the OpenAPI document has no paths object" $ do+ let json = [here|+{+ "openapi": "3.0.0",+ "info": { "title": "info example", "version": "1.0.0" },+ "components": {+ }+}+|]+ toApiDefinition json `shouldBe` Nothing++ describe "getRequestBodySchema" $ do+ context "when getting POST request body schema" $ do+ it "returns Just BodySchema if the specified path is defined" $+ getRequestBodySchema apiDef POST "/articles" `shouldSatisfy` isJust++ it "returns Nothing if the specified path is defined but POST method is not available" $+ getRequestBodySchema apiDef POST "/articles/1" `shouldBe` Nothing++ it "returns Nothing if the specified path is not defined" $+ getRequestBodySchema apiDef POST "/null" `shouldBe` Nothing++ context "when getting PUT request body schema" $ do+ it "returns Just BodySchema if the specified path is defined" $+ getRequestBodySchema apiDef PUT "/articles/1" `shouldSatisfy` isJust++ it "returns Nothing if the specified path is defined but PUT method is not available" $+ getRequestBodySchema apiDef PUT "/articles" `shouldBe` Nothing++ it "returns Nothing if the specified path is not defined" $+ getRequestBodySchema apiDef PUT "/null" `shouldBe` Nothing++ context "when getting GET request body schema" $+ it "returns Nothing if the specified path is defined but request body schema is not defined" $+ getRequestBodySchema apiDef GET "/articles" `shouldBe` Nothing++ describe "getRequestBodyReferencedSchema" $ do+ context "when getting POST request body schema" $ do+ it "returns Just (Referenced Schema) if the operation for the specified path is defined" $+ getRequestBodyReferencedSchema apiDef _pathItemPost "/articles" `shouldSatisfy` isJust++ it "returns Nothing if the operation for the specified path is not defined" $+ getRequestBodyReferencedSchema apiDef _pathItemPost "/articles/1" `shouldBe` Nothing++ it "returns Nothing if the specified path is defined" $+ getRequestBodyReferencedSchema apiDef _pathItemPost "/null" `shouldBe` Nothing++ context "when getting PUT request body schema" $ do+ it "returns Just (Referenced Schema) if the operation for the specified path is not defined" $+ getRequestBodyReferencedSchema apiDef _pathItemPut "/articles/1" `shouldSatisfy` isJust++ it "returns Nothing if the operation for the specified path is defined" $+ getRequestBodyReferencedSchema apiDef _pathItemPut "/articles" `shouldBe` Nothing++ it "returns Nothing if the specified path is defined" $+ getRequestBodyReferencedSchema apiDef _pathItemPut "/null" `shouldBe` Nothing++ context "when getting GET request body schema" $+ it "returns Nothing if the specified path is defined but request body schema is not defined" $+ getRequestBodyReferencedSchema apiDef _pathItemGet "/articles" `shouldBe` Nothing++ describe "getResponseBodySchema" $ do+ context "when getting GET response body schema" $ do+ it "returns Just BodySchema if the specified path and the status is defined" $+ getResponseBodySchema apiDef GET "/articles" 200 `shouldSatisfy` isJust++ it "returns Nothing if the specified path is defined but the status is not defined" $+ getResponseBodySchema apiDef GET "/articles" 300 `shouldBe` Nothing++ it "returns Nothing if the specified path is not defined" $+ getResponseBodySchema apiDef GET "/null" 200 `shouldBe` Nothing++ context "when getting POST request body schema" $+ it "returns Nothing if the specified path is defined but the response schema is not defined" $+ getResponseBodySchema apiDef POST "/articles" 200 `shouldBe` Nothing++ describe "getResponseBodyReferencedSchema" $ do+ context "when getting GET response body schema" $ do+ it "returns Just (Referenced Schema) if the operation for the specified path is defined" $+ getResponseBodyReferencedSchema apiDef _pathItemGet "/articles" 200 `shouldSatisfy` isJust++ it "returns Nothing if the operation for the specified path is not defined" $+ getResponseBodyReferencedSchema apiDef _pathItemGet "/articles" 300 `shouldBe` Nothing++ it "returns Nothing if the specified path is defined" $+ getResponseBodyReferencedSchema apiDef _pathItemGet "/null" 200 `shouldBe` Nothing++ context "when getting POST response body schema" $+ it "returns Nothing if the specified path is defined but the response schema is not defined" $+ getResponseBodyReferencedSchema apiDef _pathItemPost "/articles" 200 `shouldBe` Nothing++ describe "getPathItem" $ do+ it "returns Just PathItem if the specified path is defined" $+ getPathItem apiDef "/articles" `shouldSatisfy` isJust++ it "returns Just PathItem if the specified templated path is defined" $+ getPathItem apiDef "/articles/1" `shouldSatisfy` isJust++ it "returns Nothing if the specified path is not defined" $+ getPathItem apiDef "/null" `shouldBe` Nothing++ describe "validateJsonDocument" $ do+ context "when validating POST request body" $ do+ it "returns Right [] if the request body satisfy all constraints" $ do+ let requestBodyJson = [here|+{+ "cint": 1,+ "ctxt": "foo"+}+|]+ validateJsonDocument apiDef postRequestBodySchema requestBodyJson `shouldBe` Right []++ it "returns validation errors if the request body does not satisfy any constraints" $ do+ let requestBodyJson = [here|+{+ "cint": "foo",+ "ctxt": "foo"+}+|]+ validateJsonDocument apiDef postRequestBodySchema requestBodyJson `shouldSatisfy` hasValidationError++ context "when validating PUT request body" $ do+ it "returns Right [] if the request body satisfy all constraints" $ do+ let requestBodyJson = [here|+{+ "cint": 1,+ "ctxt": "foo"+}+|]+ validateJsonDocument apiDef putRequestBodySchema requestBodyJson `shouldBe` Right []++ it "returns validation errors if the request body does not satisfy any constraints" $ do+ let requestBodyJson = [here|+{+ "cint": "foo",+ "ctxt": "foo"+}+|]+ validateJsonDocument apiDef putRequestBodySchema requestBodyJson `shouldSatisfy` hasValidationError++ it "returns Left if the request body is not valid JSON" $ do+ let requestBodyJson = [here|+cint: 1+ctxt: "foo"+|]+ validateJsonDocument apiDef putRequestBodySchema requestBodyJson `shouldSatisfy` isLeft++hasValidationError :: Either String [String] -> Bool+hasValidationError (Right []) = False+hasValidationError (Right _) = True+hasValidationError (Left _) = False
+ test/Network/Wai/Middleware/ValidationSpec.hs view
@@ -0,0 +1,852 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Network.Wai.Middleware.ValidationSpec (spec) where++import Control.Monad (forM_)+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString.Lazy as L+import Data.Maybe (fromMaybe, isJust)+import Data.String.Here (here)+import Network.HTTP.Types (StdMethod (GET, POST), methodPost, status201,+ status400, status500)+import Network.Wai (requestMethod, responseLBS)+import Network.Wai.Test+import Test.Hspec++import Network.Wai.Middleware.Validation+++openApiJson :: L.ByteString+openApiJson = [here|+{+ "openapi": "3.0.0",+ "info": { "title": "validator test", "version": "1.0.0" },+ "paths": {+ "/articles": {+ "get": {+ "responses": {+ "200": {+ "description": "OK",+ "content": {+ "application/json": {+ "schema": {+ "type": "array",+ "items": {+ "$ref": "#/components/schemas/Article"+ }+ }+ }+ }+ }+ }+ },+ "post": {+ "requestBody": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/Article"+ }+ }+ }+ },+ "responses": {+ "201": {+ "description": "OK",+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/Article"+ }+ }+ }+ }+ }+ }+ },+ "/articles/{articleId}": {+ "parameters": [+ {+ "name": "articleId",+ "in": "path",+ "required": true,+ "schema": { "type": "integer" }+ }+ ],+ "put": {+ "requestBody": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/Article"+ }+ }+ }+ },+ "responses": { "default": { "description": "response example" } }+ }+ }+ },+ "components": {+ "schemas": {+ "Article": {+ "type": "object",+ "required": [ "cint", "ctxt" ],+ "properties": {+ "cint": { "type": "integer" },+ "ctxt": { "type": "string" }+ }+ }+ }+ }+}+|]+++spec :: Spec+spec = do+ describe "Middleware" $ do+ let+ mkApp responseBody _ respond = respond $ responseLBS status201 responseHeaders responseBody+ validResponseBody = [here| {"cint": 1, "ctxt": "RESPONSE"} |]+ invalidResponseBody = [here| {"cint": 1} |]+ mkSession requestBody = srequest $ SRequest (setPath (defaultRequest {requestMethod = methodPost}) "/articles") requestBody+ validRequestBody = [here| {"cint": 1, "ctxt": "REQUEST"} |]+ invalidRequestBody = [here| {"cint": 1, "ctxt": 0} |]++ context "request and response validation" $ do+ let validator = fromMaybe (error "Invalid OpenAPI document") (mkValidator' openApiJson)++ it "do nothing if the request and response body is valid" $ do+ sResponse <- liftIO $ runSession (mkSession validRequestBody) $ validator (mkApp validResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe` (status201, validResponseBody)++ it "returns 400 if the request body is invalid" $ do+ sResponse <- liftIO $ runSession (mkSession invalidRequestBody) $ validator (mkApp validResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe`+ (status400, [here| {"title":"Validation failed","detail":"expected JSON value of type string\n"} |])++ it "returns 500 if the response body is invalid" $ do+ sResponse <- liftIO $ runSession (mkSession validRequestBody) $ validator (mkApp invalidResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe`+ (status500, [here| {"title":"Validation failed","detail":"property \"ctxt\" is required, but not found in \"{\\\"cint\\\":1}\"\n"} |])++ context "request validation" $ do+ let reqValidator = fromMaybe (error "Invalid OpenAPI document") (mkRequestValidator' openApiJson)++ it "do nothing if the request and response body is valid" $ do+ sResponse <- liftIO $ runSession (mkSession validRequestBody) $ reqValidator (mkApp validResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe` (status201, validResponseBody)++ it "returns 400 if the request body is invalid" $ do+ sResponse <- liftIO $ runSession (mkSession invalidRequestBody) $ reqValidator (mkApp validResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe`+ (status400, [here| {"title":"Validation failed","detail":"expected JSON value of type string\n"} |])++ it "do nothing even if the response body is invalid" $ do+ sResponse <- liftIO $ runSession (mkSession validRequestBody) $ reqValidator (mkApp invalidResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe` (status201, invalidResponseBody)++ context "response validation" $ do+ let resValidator = fromMaybe (error "Invalid OpenAPI document") (mkResponseValidator' openApiJson)++ it "do nothing if the request and response body is valid" $ do+ sResponse <- liftIO $ runSession (mkSession validRequestBody) $ resValidator (mkApp validResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe` (status201, validResponseBody)++ it "do nothing even if the request body is invalid" $ do+ sResponse <- liftIO $ runSession (mkSession invalidRequestBody) $ resValidator (mkApp validResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe` (status201, validResponseBody)++ it "returns 500 if the response body is invalid" $ do+ sResponse <- liftIO $ runSession (mkSession validRequestBody) $ resValidator (mkApp invalidResponseBody)+ (simpleStatus sResponse, simpleBody sResponse) `shouldBe`+ (status500, [here| {"title":"Validation failed","detail":"property \"ctxt\" is required, but not found in \"{\\\"cint\\\":1}\"\n"} |])++ describe "mkValidator'" $ do+ it "returns Just Middleware if the OpenAPI document is valid" $+ isJust (mkValidator' openApiJson) `shouldBe` True++ it "returns Nothing if the OpenAPI document is invalid" $+ isJust (mkValidator' "") `shouldBe` False++ it "returns Nothing if the OpenAPI document has no paths object" $ do+ let json = [here|+{+ "openapi": "3.0.0",+ "info": { "title": "info example", "version": "1.0.0" },+ "components": {+ }+}+|]+ isJust (mkValidator' json) `shouldBe` False++ describe "mkRequestValidator'" $ do+ it "returns Just Middleware if the OpenAPI document is valid" $+ isJust (mkRequestValidator' openApiJson) `shouldBe` True++ it "returns Nothing if the OpenAPI document is invalid" $+ isJust (mkRequestValidator' "") `shouldBe` False++ it "returns Nothing if the OpenAPI document has no paths object" $ do+ let json = [here|+{+ "openapi": "3.0.0",+ "info": { "title": "info example", "version": "1.0.0" },+ "components": {+ }+}+|]+ isJust (mkRequestValidator' json) `shouldBe` False++ describe "mkResponseValidator'" $ do+ it "returns Just Middleware if the OpenAPI document is valid" $+ isJust (mkResponseValidator' openApiJson) `shouldBe` True++ it "returns Nothing if the OpenAPI document is invalid" $+ isJust (mkResponseValidator' "") `shouldBe` False++ it "returns Nothing if the OpenAPI document has no paths object" $ do+ let json = [here|+{+ "openapi": "3.0.0",+ "info": { "title": "info example", "version": "1.0.0" },+ "components": {+ }+}+|]+ isJust (mkResponseValidator' json) `shouldBe` False++ describe "validateRequestBody" $ do+ let makeOpenApiJson schemaJson = [here|+{+ "openapi": "3.0.0",+ "info": { "title": "info example", "version": "1.0.0" },+ "paths": {+ "/examples": {+ "post": {+ "requestBody": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/Example"+ }+ }+ }+ },+ "responses": { "default": { "description": "response example" } }+ }+ }+ },+ "components": {+ "schemas": {+ "Example": {+ "type": "object",+ "properties": |] <> schemaJson <> [here|+ }+ }+ }+}+|]+ context "type: integer" $ do+ let+ tests =+ [ ( "returns Right [] if the value is integer"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": 1} |]+ , Right []+ )+ , ( "returns Right [] if the value is integer"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": 1} |]+ , Right []+ )+ , ( "returns Right [] if the value is integer"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": 1} |]+ , Right []+ )+ , ( "returns Right [error] if the value is a number contains a decimal part"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": 1.1} |]+ , Right ["not an integer"]+ )+ , ( "returns Right [error] if the value is a string type"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": "text"} |]+ , Right ["expected JSON value of type integer"]+ )+ , ( "returns Right [error] if the value is a boolean type"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": true} |]+ , Right ["expected JSON value of type integer"]+ )+ , ( "returns Right [error] if the value is an array type"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": [0, 1, 2]} |]+ , Right ["expected JSON value of type integer"]+ )+ , ( "returns Right [error] if the value is an object type"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": {"k": "v"}} |]+ , Right ["expected JSON value of type integer"]+ )+ , ( "returns Right [] if the value is the same as the minimum"+ , [here| {"mint": {"type": "integer", "minimum": 10}} |]+ , [here| {"mint": 10} |]+ , Right []+ )+ , ( "returns Right [error] if the value is less than the minimum"+ , [here| {"mint": {"type": "integer", "minimum": 10}} |]+ , [here| {"mint": 9} |]+ , Right ["value 9.0 falls below minimum (should be >=10.0)"]+ )+ , ( "returns Right [] if the value is the same as the minimum and exclusiveMinimum is true"+ , [here| {"mint": {"type": "integer", "minimum": 10, "exclusiveMinimum": true}} |]+ , [here| {"mint": 10} |]+ , Right ["value 10.0 falls below minimum (should be >10.0)"]+ )+ , ( "returns Right [] if the value is the same as the minimum and exclusiveMinimum is false"+ , [here| {"mint": {"type": "integer", "minimum": 10, "exclusiveMinimum": false}} |]+ , [here| {"mint": 10} |]+ , Right []+ )+ , ( "returns Right [] if the value is the same as the maximum"+ , [here| {"mint": {"type": "integer", "maximum": 10}} |]+ , [here| {"mint": 10} |]+ , Right []+ )+ , ( "returns Right [error] if the value is greater than the maximum"+ , [here| {"mint": {"type": "integer", "maximum": 10}} |]+ , [here| {"mint": 11} |]+ , Right ["value 11.0 exceeds maximum (should be <=10.0)"]+ )+ , ( "returns Right [] if the value is the same as the maximum and exclusiveMaximum is true"+ , [here| {"mint": {"type": "integer", "maximum": 10, "exclusiveMaximum": true}} |]+ , [here| {"mint": 11} |]+ , Right ["value 11.0 exceeds maximum (should be <10.0)"]+ )+ , ( "returns Right [] if the value is the same as the maximum and exclusiveMaximum is false"+ , [here| {"mint": {"type": "integer", "maximum": 10, "exclusiveMaximum": false}} |]+ , [here| {"mint": 10} |]+ , Right []+ )+ , ( "returns Right [] if the value is the multiple of the value of multipleOf"+ , [here| {"mint": {"type": "integer", "multipleOf": 5}} |]+ , [here| {"mint": 10} |]+ , Right []+ )+ , ( "returns Right [error] if the value is not the multiple of the value of multipleOf"+ , [here| {"mint": {"type": "integer", "multipleOf": 4}} |]+ , [here| {"mint": 10} |]+ , Right ["expected a multiple of 4.0 but got 10.0"]+ )+ , ( "returns Right [] if the value is the maximum value of int32"+ , [here| {"mint": {"type": "integer", "format": "int32"}} |]+ , [here| {"mint": 2147483647} |]+ , Right []+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "type: number" $ do+ let+ tests =+ [ ( "returns Right [] if the value is a number contains a decimal part"+ , [here| {"mnum": {"type": "number"}} |]+ , [here| {"mnum": 1.1} |]+ , Right []+ )+ , ( "returns Right [] if the value is an integer"+ , [here| {"mnum": {"type": "number"}} |]+ , [here| {"mnum": 1} |]+ , Right []+ )+ , ( "returns Right [error] if the value is a string type"+ , [here| {"mnum": {"type": "number"}} |]+ , [here| {"mnum": "text"} |]+ , Right ["expected JSON value of type number"]+ )+ , ( "returns Right [error] if the value is a boolean type"+ , [here| {"mnum": {"type": "number"}} |]+ , [here| {"mnum": true} |]+ , Right ["expected JSON value of type number"]+ )+ , ( "returns Right [error] if the value is an array type"+ , [here| {"mnum": {"type": "number"}} |]+ , [here| {"mnum": [0, 1, 2 ]} |]+ , Right ["expected JSON value of type number"]+ )+ , ( "returns Right [error] if the value is an object type"+ , [here| {"mnum": {"type": "number"}} |]+ , [here| {"mnum": {"k": "v"}} |]+ , Right ["expected JSON value of type number"]+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "type: string" $ do+ let+ tests =+ [ ( "returns Right [] if the value is a string type"+ , [here| {"mstr": {"type": "string"}} |]+ , [here| {"mstr": "text"} |]+ , Right []+ )+ , ( "returns Right [error] if the value is an integer type"+ , [here| {"mstr": {"type": "string"}} |]+ , [here| {"mstr": 1} |]+ , Right ["expected JSON value of type string"]+ )+ , ( "returns Right [error] if the value is a number type"+ , [here| {"mstr": {"type": "string"}} |]+ , [here| {"mstr": 1.1} |]+ , Right ["expected JSON value of type string"]+ )+ , ( "returns Right [error] if the value is a boolean type"+ , [here| {"mstr": {"type": "string"}} |]+ , [here| {"mstr": true} |]+ , Right ["expected JSON value of type string"]+ )+ , ( "returns Right [error] if the value is an array type"+ , [here| {"mstr": {"type": "string"}} |]+ , [here| {"mstr": [0, 1, 2]} |]+ , Right ["expected JSON value of type string"]+ )+ , ( "returns Right [error] if the value is an object type"+ , [here| {"mstr": {"type": "string"}} |]+ , [here| {"mstr": {"k": "v"}} |]+ , Right ["expected JSON value of type string"]+ )+ , ( "returns Right [] if the length of the value is the same as minLength"+ , [here| {"mstr": {"type": "string", "minLength": 3}} |]+ , [here| { "mstr": "abc" } |]+ , Right []+ )+ , ( "returns Right [error] if the length of the value is less than minLength"+ , [here| {"mstr": {"type": "string", "minLength": 4}} |]+ , [here| { "mstr": "abc" } |]+ , Right ["string is too short (length should be >=4)"]+ )+ , ( "returns Right [] if the length of the value is the same as maxLength"+ , [here| {"mstr": {"type": "string", "maxLength": 3}} |]+ , [here| { "mstr": "abc" } |]+ , Right []+ )+ , ( "returns Right [error] if the length of the value is greater than maxLength"+ , [here| {"mstr": {"type": "string", "maxLength": 2}} |]+ , [here| { "mstr": "abc" } |]+ , Right ["string is too long (length should be <=2)"]+ )+ , ( "returns Right [] if the value follows format:date"+ , [here| {"mstr": {"type": "string", "format": "date"}} |]+ , [here| { "mstr": "2017-07-21" } |]+ , Right []+ )+ , ( "returns Right [] if the value follows format:date-time"+ , [here| {"mstr": {"type": "string", "format": "date-time"}} |]+ , [here| { "mstr": "2017-07-21T17:32:28Z" } |]+ , Right []+ )+ , ( "returns Right [] if the value follows format:byte"+ , [here| {"mstr": {"type": "string", "format": "byte"}} |]+ , [here| {"mstr": "U3dhZ2dlciByb2Nrcw=="} |]+ , Right []+ )+ , ( "returns Right [] if the value matches the pattern"+ , [here| {"mstr": {"type": "string", "pattern": "^abc$"}} |]+ , [here| {"mstr": "abc"} |]+ , Right []+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "type: string (pending)" $ do+ let+ tests =+ [ ( "returns Right [] if the value does not follows format:date"+ , [here| {"mstr": {"type": "string", "format": "date"}} |]+ , [here| { "mstr": "not date!" } |]+ -- , Right ["expected JSON value of type string and format of date"]+ , "Keyword `format` is not supported"+ )+ , ( "returns Right [] if the value does not follows format:date-time"+ , [here| {"mstr": {"type": "string", "format": "date-time"}} |]+ , [here| {"mstr": "not datetime!"} |]+ -- , Right ["expected JSON value of type string and format of date-time"]+ , "Keyword `format` is not supported"+ )+ , ( "returns Right [] if the value does not follows format:byte"+ , [here| {"mstr": {"type": "string", "format": "byte"}} |]+ , [here| {"mstr": "not byte!"} |]+ -- , Right ["expected JSON value of type string and format of byte"]+ , "Keyword `format` is not supported"+ )+ , ( "returns Right [error] if the value does not matches the pattern"+ , [here| {"mstr": {"type": "string", "pattern": "^abc$"}} |]+ , [here| {"mstr": "def"} |]+ -- , Right ["expected JSON value of type string and of pattern"]+ , "Keyword `pattern` is not supported"+ )+ ] :: [(String, L.ByteString, L.ByteString, String)]+ -- forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ -- it description $ do+ -- let apiJson = makeOpenApiJson schemaJson+ -- validateRequestBody POST "/examples" apiJson bodyJson `shouldNotBe` result+ forM_ tests $ \(description, _, _, reason) ->+ it description $+ pendingWith reason++ context "type: boolean" $ do+ let+ tests =+ [ ( "returns Right [] if the value is an boolean value"+ , [here| {"mbol": {"type": "boolean"}} |]+ , [here| {"mbol": true} |]+ , Right []+ )+ , ( "returns Right [error] if the value is an integer type"+ , [here| {"mbol": {"type": "boolean"}} |]+ , [here| {"mbol": 1} |]+ , Right ["expected JSON value of type boolean"]+ )+ , ( "returns Right [error] if the value is a number type"+ , [here| {"mbol": {"type": "boolean"}} |]+ , [here| {"mbol": 1.1} |]+ , Right ["expected JSON value of type boolean"]+ )+ , ( "returns Right [error] if the value is a string type"+ , [here| {"mbol": {"type": "boolean"}} |]+ , [here| {"mbol": "text"} |]+ , Right ["expected JSON value of type boolean"]+ )+ , ( "returns Right [error] if the value is an array type"+ , [here| {"mbol": {"type": "boolean"}} |]+ , [here| {"mbol": [0, 1, 2]} |]+ , Right ["expected JSON value of type boolean"]+ )+ , ( "returns Right [error] if the value is an object type"+ , [here| {"mbol": {"type": "boolean"}} |]+ , [here| {"mbol": {"k": "v"}} |]+ , Right ["expected JSON value of type boolean"]+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "type: array" $ do+ let+ tests =+ [ ( "returns Right [] if all values in the list are the correct type"+ , [here| {"mlst": {"type": "array", "items": {"type": "integer"}}} |]+ , [here| {"mlst": [1, 2]} |]+ , Right []+ )+ , ( "returns Right [error] if there are different types of values in the list"+ , [here| {"mlst": {"type": "array", "items": {"type": "integer"}}} |]+ , [here| {"mlst": [1, "2"]} |]+ , Right ["expected JSON value of type integer"]+ )+ , ( "returns Right [] if all values in the tuple are the correct type"+ , [here| {"mtpl": {"type": "array", "items": [{"type": "integer"}, {"type": "string"}]}} |]+ , [here| {"mtpl": [1, "text"]} |]+ , Right []+ )+ , ( "returns Right [error] if there are different types of values in the tuple"+ , [here| {"mtpl": {"type": "array", "items": [{"type": "integer"}, {"type": "string"}]}} |]+ , [here| {"mtpl": [1, 2]} |]+ , Right ["expected JSON value of type string"]+ )+ , ( "returns Right [error] if the number of elements in the array is less than minItems"+ , [here| {"mlst": {"type": "array", "items": {"type": "integer"}, "minItems": 2}} |]+ , [here| {"mlst": [1]} |]+ , Right ["array is too short (size should be >=2)"]+ )+ , ( "returns Right [error] if the number of elements in the array is greater than maxItems"+ , [here| {"mlst": {"type": "array", "items": {"type": "integer"}, "maxItems": 2}} |]+ , [here| {"mlst": [1, 2, 3]} |]+ , Right ["array exceeds maximum size (should be <=2)"]+ )+ , ( "returns Right [] if uniqueItems is not specified and the array has some duplicated values"+ , [here| {"mlst": {"type": "array", "items": {"type": "integer"}}} |]+ , [here| {"mlst": [1, 2, 1]} |]+ , Right []+ )+ , ( "returns Right [error] if uniqueItems is true and the array has some duplicated values"+ , [here| {"mlst": {"type": "array", "items": {"type": "integer"}, "uniqueItems": true}} |]+ , [here| {"mlst": [1, 2, 1]} |]+ , Right ["array is expected to contain unique items, but it does not"]+ )+ , ( "returns Right [error] if uniqueItems is false and the array has some duplicated values"+ , [here| {"mlst": {"type": "array", "items": {"type": "integer"}, "uniqueItems": false}} |]+ , [here| {"mlst": [1, 2, 1]} |]+ , Right []+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "type: object" $ do+ let+ tests =+ [ ( "returns Right [error] if the value contains undefined property"+ , [here|+{+ "mobj": {+ "type": "object",+ "properties": {+ "mint": {"type": "integer"}+ }+ }+}+|]+ , [here| {"mobj": {"mstr": "hello"}} |]+ , Right ["property \"mstr\" is found in JSON value, but it is not mentioned in Swagger schema"]+ )+ , ( "returns Right [] if the value contains required property"+ , [here|+{+ "mobj": {+ "type": "object",+ "required": ["cint", "cstr"],+ "properties": {+ "cint": {"type": "integer"},+ "cstr": {"type": "string"},+ "mbol": {"type": "boolean"}+ }+ }+}+|]+ , [here| {"mobj": {"cint": 1, "cstr": "hello"}} |]+ , Right []+ )+ , ( "returns Right [error] if the value does not contains required property"+ , [here|+{+ "mobj": {+ "type": "object",+ "required": ["cint", "cstr"],+ "properties": {+ "cint": {"type": "integer"},+ "cstr": {"type": "string"},+ "mbol": {"type": "boolean"}+ }+ }+}+|]+ , [here| {"mobj": {"cint": 1, "mbol": true}} |]+ , Right ["property \"cstr\" is required, but not found in \"{\\\"mbol\\\":true,\\\"cint\\\":1}\""]+ )+ , ( "returns Right [] if the number of properties of the value is greater than or equal to than minProperties"+ , [here|+{+ "mobj": {+ "type": "object",+ "minProperties": 2,+ "properties": {+ "mint": {"type": "integer"},+ "mstr": {"type": "string"},+ "mbol": {"type": "boolean"}+ }+ }+}+|]+ , [here| {"mobj": {"mint": 1, "mstr": "text"}} |]+ , Right []+ )+ , ( "returns Right [error] if the number of properties of the value is less than minProperties"+ , [here|+{+ "mobj": {+ "type": "object",+ "minProperties": 2,+ "properties": {+ "mint": {"type": "integer"},+ "mstr": {"type": "string"},+ "mbol": {"type": "boolean"}+ }+ }+}+|]+ , [here| {"mobj": {"mint": 1}} |]+ , Right ["object size is too small (total number of properties should be >=2)"]+ )+ , ( "returns Right [] if the number of properties of the value is less than or equal to maxProperties"+ , [here|+{+ "mobj": {+ "type": "object",+ "maxProperties": 2,+ "properties": {+ "mint": {"type": "integer"},+ "mstr": {"type": "string"},+ "mbol": {"type": "boolean"}+ }+ }+}+|]+ , [here| {"mobj": {"mint": 1, "mstr": "text"}} |]+ , Right []+ )+ , ( "returns Right [error] if the number of properties of the value is greater than maxProperties"+ , [here|+{+ "mobj": {+ "type": "object",+ "maxProperties": 2,+ "properties": {+ "mint": {"type": "integer"},+ "mstr": {"type": "string"},+ "mbol": {"type": "boolean"}+ }+ }+}+|]+ , [here| {"mobj": {"mint": 1, "mstr": "text", "mbol": true}} |]+ , Right ["object size exceeds maximum (total number of properties should be <=2)"]+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "enum" $ do+ let+ tests =+ [ ( "returns Right [] if the value is one of the enumerated values"+ , [here| {"mint": {"type": "integer", "enum": [10, 20, 30]}} |]+ , [here| {"mint": 10} |]+ , Right []+ )+ , ( "returns Right [error] if the value is not one of the enumerated values"+ , [here| {"mint": {"type": "integer", "enum": [20, 30]}} |]+ , [here| {"mint": 10} |]+ , Right ["expected one of \"[20,30]\" but got Number 10.0"]+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "description" $ do+ let+ tests =+ [ ( "returns Right [] if the description is defined"+ , [here| {"mint": {"type": "integer", "description": "Can be any integer value"}} |]+ , [here| {"mint": 1} |]+ , Right []+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "nullable" $ do+ let+ tests =+ [ ( "returns Right [] if nullable is true and the value is null"+ , [here| {"mint": {"type": "integer", "nullable": true}} |]+ , [here| {"mint": null} |]+ , Right []+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateRequestBody POST "/examples" apiJson bodyJson `shouldBe` result++ context "nullable (pending)" $ do+ let+ tests =+ [ ( "returns Right [error] if nullable is false and the value is null"+ , [here| {"mint": {"type": "integer", "nullable": false}} |]+ , [here| {"mint": null} |]+ -- , Right ["expected JSON value of type not null"]+ , "Keyword `nullable` is not supported"+ )+ , ( "returns Right [error] if nullable is not specified and the value is null"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| {"mint": null} |]+ -- , Right ["expected JSON value of type not null"]+ , "Keyword `nullable` is not supported"+ )+ ] :: [(String, L.ByteString, L.ByteString, String)]+ -- forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ -- it description $ do+ -- let apiJson = makeOpenApiJson schemaJson+ -- validateRequestBody POST "/examples" apiJson bodyJson `shouldNotBe` result+ forM_ tests $ \(description, _, _, reason) ->+ it description $+ pendingWith reason++ describe "validateResponseBody" $ do+ let makeOpenApiJson schemaJson = [here|+{+ "openapi": "3.0.0",+ "info": { "title": "info example", "version": "1.0.0" },+ "paths": {+ "/examples": {+ "get": {+ "responses": {+ "200": {+ "description": "OK",+ "content": {+ "application/json": {+ "schema": {+ "type": "array",+ "items": {+ "$ref": "#/components/schemas/Example"+ }+ }+ }+ }+ }+ }+ }+ }+ },+ "components": {+ "schemas": {+ "Example": {+ "type": "object",+ "properties": |] <> schemaJson <> [here|+ }+ }+ }+}+|]+ context "type: integer" $ do+ let+ tests =+ [ ( "returns Right [] if the type of the value is valid"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| [{"mint": 1}, {"mint": 2}] |]+ , Right []+ )+ , ( "returns Right [] if the type of the value is invalid"+ , [here| {"mint": {"type": "integer"}} |]+ , [here| [{"mint": 1}, {"mint": "two"}] |]+ , Right ["expected JSON value of type integer"]+ )+ ]+ forM_ tests $ \(description, schemaJson, bodyJson, result) ->+ it description $ do+ let apiJson = makeOpenApiJson schemaJson+ validateResponseBody GET "/examples" 200 apiJson bodyJson `shouldBe` result
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/doctest/doctest-driver.hs view
@@ -0,0 +1,9 @@+-- {-# OPTIONS_GHC -F -pgmF doctest-driver -optF config.json #-}+import Test.DocTest++main :: IO ()+main = doctest+ [ "-isrc"+ , "-XOverloadedStrings"+ , "src/Network/Wai/Middleware/Validation/Internal.hs"+ ]
+ wai-middleware-validation.cabal view
@@ -0,0 +1,63 @@+name: wai-middleware-validation+version: 0.1.0.0+synopsis: WAI Middleware to validate the request and response bodies+description: Please see the README on GitHub at <https://github.com/iij-ii/wai-middleware-validation#readme>+homepage: https://github.com/iij-ii/wai-middleware-validation#readme+license: BSD3+license-file: LICENSE+author: Kenzo Yotsuya+maintainer: kyotsuya@iij-ii.co.jp+copyright: IIJ Innovation Institute Inc.+category: Web+build-type: Simple+extra-source-files: README.md+ , ChangeLog.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Network.Wai.Middleware.Validation+ Network.Wai.Middleware.Validation.Internal+ build-depends: base >= 4.7 && < 5+ , aeson+ , bytestring+ , containers+ , filepath+ , http-types+ , insert-ordered-containers+ , lens+ , openapi3+ , text+ , wai+ default-language: Haskell2010++test-suite wai-middleware-validation-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: Network.Wai.Middleware.ValidationSpec+ Network.Wai.Middleware.Validation.InternalSpec+ hs-source-dirs: test+ ghc-options: -Wall+ build-depends: base >= 4.7 && < 5+ , bytestring+ , here+ , hspec+ , http-types+ , openapi3+ , wai+ , wai-extra+ , wai-middleware-validation+ default-language: Haskell2010++test-suite wai-middleware-validation-doctest+ type: exitcode-stdio-1.0+ main-is: doctest-driver.hs+ hs-source-dirs: test/doctest+ ghc-options: -Wall+ build-depends: base >= 4.7 && < 5+ , doctest+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/iij-ii/wai-middleware-validation