diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for wai-middleware-validation + +## 0.1.0.0 (2021-03-17) + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,41 @@ +# wai-middleware-validation [![CircleCI](https://circleci.com/gh/iij-ii/wai-middleware-validation.svg?style=svg)](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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Network/Wai/Middleware/Validation.hs b/src/Network/Wai/Middleware/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Validation.hs @@ -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 diff --git a/src/Network/Wai/Middleware/Validation/Internal.hs b/src/Network/Wai/Middleware/Validation/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Validation/Internal.hs @@ -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") + ] diff --git a/test/Network/Wai/Middleware/Validation/InternalSpec.hs b/test/Network/Wai/Middleware/Validation/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/Validation/InternalSpec.hs @@ -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 diff --git a/test/Network/Wai/Middleware/ValidationSpec.hs b/test/Network/Wai/Middleware/ValidationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/ValidationSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/doctest/doctest-driver.hs b/test/doctest/doctest-driver.hs new file mode 100644 --- /dev/null +++ b/test/doctest/doctest-driver.hs @@ -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" + ] diff --git a/wai-middleware-validation.cabal b/wai-middleware-validation.cabal new file mode 100644 --- /dev/null +++ b/wai-middleware-validation.cabal @@ -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 +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