diff --git a/JSON-Schema-Test-Suite/remotes/integer.json b/JSON-Schema-Test-Suite/remotes/integer.json new file mode 100644 --- /dev/null +++ b/JSON-Schema-Test-Suite/remotes/integer.json @@ -0,0 +1,3 @@ +{ + "type": "integer" +} diff --git a/JSON-Schema-Test-Suite/remotes/subSchemas.json b/JSON-Schema-Test-Suite/remotes/subSchemas.json new file mode 100644 --- /dev/null +++ b/JSON-Schema-Test-Suite/remotes/subSchemas.json @@ -0,0 +1,8 @@ +{ + "integer": { + "type": "integer" + }, + "refToInteger": { + "$ref": "#/integer" + } +} diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,23 +8,21 @@ # Example -See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Example.hs). +See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Simple.hs). # Tests -## Install - -`git submodule update --init` +Run all tests: -## Run +`stack test` -Will run self-contained: +Run only local tests: -`cabal test local` +`stack test hjsonschema:local` -Will start an HTTP server temporarily on port 1234: +Run remote tests (makes GETs to json-schema.org, also temporarily starts an HTTP server on port 1234): -`cabal test remote` +`stack test hjsonschema:remote` # Details @@ -42,11 +40,13 @@ ## Bad Parts -+ Uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library for the "pattern" validator. It should use a library based on the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires. ++ Uses the [pcre-heavy](https://hackage.haskell.org/package/pcre-heavy) regular expression library for the "pattern" validator. It should use a library based on the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires. ## Notes -+ `draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema). ++ `JSON-Schema-Test-Suite` is vendored from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite). + ++ `src/draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema). ## Credits diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -1,3 +1,13 @@ +# 0.10 + ++ Rewrite fetching internals. ++ Fix reference resolution defects, add more tests. ++ Switch to a Perl style regex library, which is closer to ECMAScript regexes +than the previous Posix style one. ++ Add one-step validation functions ('fetchFilesystemAndValidate' and 'fetchHTTPAndValidate'). ++ Alias the validation failure type exported by 'Data.JsonSchema.Draft4' to +'Invalid', change its field names. + # 0.9 + Partial rewrite. The API of the library has changed, see the examples diff --git a/draft4.json b/draft4.json deleted file mode 100644 --- a/draft4.json +++ /dev/null @@ -1,150 +0,0 @@ -{ - "id": "http://json-schema.org/draft-04/schema#", - "$schema": "http://json-schema.org/draft-04/schema#", - "description": "Core schema meta-schema", - "definitions": { - "schemaArray": { - "type": "array", - "minItems": 1, - "items": { "$ref": "#" } - }, - "positiveInteger": { - "type": "integer", - "minimum": 0 - }, - "positiveIntegerDefault0": { - "allOf": [ { "$ref": "#/definitions/positiveInteger" }, { "default": 0 } ] - }, - "simpleTypes": { - "enum": [ "array", "boolean", "integer", "null", "number", "object", "string" ] - }, - "stringArray": { - "type": "array", - "items": { "type": "string" }, - "minItems": 1, - "uniqueItems": true - } - }, - "type": "object", - "properties": { - "id": { - "type": "string", - "format": "uri" - }, - "$schema": { - "type": "string", - "format": "uri" - }, - "title": { - "type": "string" - }, - "description": { - "type": "string" - }, - "default": {}, - "multipleOf": { - "type": "number", - "minimum": 0, - "exclusiveMinimum": true - }, - "maximum": { - "type": "number" - }, - "exclusiveMaximum": { - "type": "boolean", - "default": false - }, - "minimum": { - "type": "number" - }, - "exclusiveMinimum": { - "type": "boolean", - "default": false - }, - "maxLength": { "$ref": "#/definitions/positiveInteger" }, - "minLength": { "$ref": "#/definitions/positiveIntegerDefault0" }, - "pattern": { - "type": "string", - "format": "regex" - }, - "additionalItems": { - "anyOf": [ - { "type": "boolean" }, - { "$ref": "#" } - ], - "default": {} - }, - "items": { - "anyOf": [ - { "$ref": "#" }, - { "$ref": "#/definitions/schemaArray" } - ], - "default": {} - }, - "maxItems": { "$ref": "#/definitions/positiveInteger" }, - "minItems": { "$ref": "#/definitions/positiveIntegerDefault0" }, - "uniqueItems": { - "type": "boolean", - "default": false - }, - "maxProperties": { "$ref": "#/definitions/positiveInteger" }, - "minProperties": { "$ref": "#/definitions/positiveIntegerDefault0" }, - "required": { "$ref": "#/definitions/stringArray" }, - "additionalProperties": { - "anyOf": [ - { "type": "boolean" }, - { "$ref": "#" } - ], - "default": {} - }, - "definitions": { - "type": "object", - "additionalProperties": { "$ref": "#" }, - "default": {} - }, - "properties": { - "type": "object", - "additionalProperties": { "$ref": "#" }, - "default": {} - }, - "patternProperties": { - "type": "object", - "additionalProperties": { "$ref": "#" }, - "default": {} - }, - "dependencies": { - "type": "object", - "additionalProperties": { - "anyOf": [ - { "$ref": "#" }, - { "$ref": "#/definitions/stringArray" } - ] - } - }, - "enum": { - "type": "array", - "minItems": 1, - "uniqueItems": true - }, - "type": { - "anyOf": [ - { "$ref": "#/definitions/simpleTypes" }, - { - "type": "array", - "items": { "$ref": "#/definitions/simpleTypes" }, - "minItems": 1, - "uniqueItems": true - } - ] - }, - "allOf": { "$ref": "#/definitions/schemaArray" }, - "anyOf": { "$ref": "#/definitions/schemaArray" }, - "oneOf": { "$ref": "#/definitions/schemaArray" }, - "not": { "$ref": "#" } - }, - "dependencies": { - "exclusiveMaximum": [ "maximum" ], - "exclusiveMinimum": [ "minimum" ] - }, - "default": {} -} diff --git a/examples/CustomSchema.hs b/examples/CustomSchema.hs --- a/examples/CustomSchema.hs +++ b/examples/CustomSchema.hs @@ -1,16 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | A custom schema made up of one validator from 'Data.Validator.Draft4' --- and one original validator. +-- | A custom schema specification using one validator from +-- 'Data.Validator.Draft4' and one original validator. -- -- This is a simple example because it doesn't allow references (so it -- doesn't need to define an 'embed' function @Schema -> [Schema]@ for use -- with 'fetchReferencedSchemas'. +-- +-- For a full example see 'Data.JsonSchema.Draft4' and its submodules. +-- Code use between schema specifications will likely be OK but not great. +-- All the 'Data.Validator' code as well as the 'Data.JsonSchema.Fetch' code +-- is reusable, but there's a lot of boilerplate to tie it together. module CustomSchema where +import Control.Applicative import Data.Aeson import Data.Maybe (maybeToList) +import Data.Monoid import Data.Text (Text) import qualified Data.Text as T @@ -21,7 +26,7 @@ oddLength :: Bool -> Text -> Maybe (FR.Failure () ) oddLength b t | b == odd (T.length t) = Nothing - | otherwise = Just (FR.Failure () (Bool b) mempty) + | otherwise = Just (FR.Invalid () (Bool b) mempty) data CustomError = MaxLength @@ -34,8 +39,8 @@ , _schemaOddLength :: Maybe Bool } --- | Since every 'Schema' is valid we don't need to bother defining something --- like 'Data.JsonSchema.Draft4.checkValidity' for this schema. +-- | If our 'Schema's themselves could be invalid we might want to write +-- something like 'Data.JsonSchema.Draft4.schemaValidityy' for them. validate :: Schema -> Value -> [FR.Failure CustomError] validate s (String x) = concat [ f _schemaMaxLength (FR.setFailure MaxLength) (fmap maybeToList . VA.maxLength) @@ -56,7 +61,7 @@ example = case validate schema badData of [] -> error "We validated bad data." - [FR.Failure OddLength _ _] -> putStrLn "Success." + [FR.Invalid OddLength _ _] -> return () -- Success. _ -> error "We got a different failure than expected." where schema :: Schema diff --git a/examples/Full.hs b/examples/Full.hs new file mode 100644 --- /dev/null +++ b/examples/Full.hs @@ -0,0 +1,34 @@ +-- | Step by step validation using 'D4.referencesViaFilesystem' and +-- 'D4.checkSchema'. This means the actual validation invovles no IO. + +module Full where + +import Data.Aeson + +import qualified Data.JsonSchema.Draft4 as D4 + +schema :: D4.Schema +schema = D4.emptySchema { D4._schemaRef = Just "./unique.json" } + +schemaContext :: D4.SchemaWithURI D4.Schema +schemaContext = D4.SchemaWithURI + { D4._swSchema = schema + , D4._swURI = Just "./examples/json/imaginary.json" + } + +badData :: Value +badData = toJSON (["foo", "foo"] :: [String]) + +example :: IO () +example = do + res <- D4.referencesViaFilesystem schemaContext + case res of + Left _ -> error "Couldn't fetch referenced schemas." + Right references -> do + let validate = case D4.checkSchema references schemaContext of + Left _ -> error "Not a valid schema." + Right f -> f + case validate badData of + [] -> error "We validated bad data." + [D4.Invalid (D4.Ref D4.UniqueItems) _ _] -> return () -- Success. + e -> error "We got a different failure than expected." diff --git a/examples/Main.hs b/examples/Main.hs deleted file mode 100644 --- a/examples/Main.hs +++ /dev/null @@ -1,19 +0,0 @@ - -module Main where - -import qualified CustomSchema as C -import qualified PrettyShowFailure as P -import qualified Standard as S - -main :: IO () -main = do - putStrLn "# Standard Example" - S.example - putStrLn "" - - putStrLn "# PrettyShowFailure Example" - P.example - putStrLn "" - - putStrLn "# CustomSchema Example" - C.example diff --git a/examples/PrettyShowFailure.hs b/examples/PrettyShowFailure.hs --- a/examples/PrettyShowFailure.hs +++ b/examples/PrettyShowFailure.hs @@ -1,4 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +-- | 'D4.Invalid's contain a JSON Pointer to the subset of the data that +-- caused validation to fail, but they don't contain that data itself. +-- +-- If you want to display the invalid subset of the data here's how you +-- resolve the JSON Pointer (which has the field name +-- 'D4._invalidOffendingData') against the original data. +-- +-- NOTE: You have to have hjsonpointer in your build-depends. module PrettyShowFailure where @@ -11,35 +18,34 @@ badData :: Value badData = toJSON [1, 2 :: Int] -failure :: D4.Failure -failure = D4.Failure - { D4._failureValidatorsCalled = D4.Items D4.MultipleOf - , D4._failureFinalValidator = Number 2 - , D4._failureOffendingData = AP.Pointer [AP.Token "0"] +failure :: D4.Invalid +failure = D4.Invalid + { D4._invalidValidatorsCalled = D4.Items D4.MultipleOf + , D4._invalidFinalValidator = Number 2 + , D4._invalidOffendingData = AP.Pointer [AP.Token "0"] } -subsetOfData :: Value -subsetOfData = - -- This is the only really interesting part of this example. To resolve the - -- pointer to the part of the data that triggered the validation failure we - -- have to have hjsonpointer in our build-depends and use 'AP.resolve'. - case AP.resolve (D4._failureOffendingData failure) badData of +example :: IO () +example = + case AP.resolve (D4._invalidOffendingData failure) badData of Left _ -> error "Couldn't resolve pointer." - Right v -> v + Right _ -> return () -- Success. We could feed the 'Right' value into + -- the otherwise unused 'msg' if we wanted to + -- display it. -example :: IO () -example = putStrLn . unlines $ +msg :: Value -> String +msg subsetOfData = unlines [ "Invalid data. Here's the sequence of validators that caught it:" , "" - , " " <> show (D4._failureValidatorsCalled failure) + , " " <> show (D4._invalidValidatorsCalled failure) , "" , "Here's the contents of the final validator in that sequence:" , "" - , " " <> show (D4._failureFinalValidator failure) + , " " <> show (D4._invalidFinalValidator failure) , "" , "Here's a JSON Pointer to the invalid part of the data:" , "" - , " " <> show (D4._failureOffendingData failure) + , " " <> show (D4._invalidOffendingData failure) , "" , "Here's the invalid part of the data:" , "" diff --git a/examples/Simple.hs b/examples/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Simple.hs @@ -0,0 +1,39 @@ +-- | Fetch any referenced schemas, check that our original schema is itself +-- valid, then validate our data. +-- +-- To fetch schemas using HTTP instead of from the filesystem use +-- 'D4.fetchHTTPAndValidate'. + +module Simple where + +import Data.Aeson +import qualified Data.List.NonEmpty as NE + +import qualified Data.JsonSchema.Draft4 as D4 + +schema :: D4.Schema +schema = D4.emptySchema { D4._schemaRef = Just "./unique.json" } + +schemaContext :: D4.SchemaWithURI D4.Schema +schemaContext = D4.SchemaWithURI + { D4._swSchema = schema + , D4._swURI = Just "./examples/json/imaginary.json" + -- ^ For this example we're pretending we found 'schema' at this location. + -- Its relative links will be resolved from here. + } + +badData :: Value +badData = toJSON (["foo", "foo"] :: [String]) + +example :: IO () +example = do + res <- D4.fetchFilesystemAndValidate schemaContext badData + case res of + Right () -> error "We validated bad data." + Left (D4.FVRead _) -> error ("Error fetching a referenced schema" + ++ " (either during IO or parsing).") + Left (D4.FVSchema _) -> error "Our 'schema' itself was invalid." + Left (D4.FVData failures) -> + case NE.toList failures of + [D4.Invalid (D4.Ref D4.UniqueItems) _ _] -> return () -- Success. + _ -> error "Got more invalidation reasons than we expected." diff --git a/examples/Standard.hs b/examples/Standard.hs deleted file mode 100644 --- a/examples/Standard.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Standard where - -import Data.Aeson -import qualified Data.HashMap.Strict as H -import qualified Data.Vector as V - -import qualified Data.JsonSchema.Draft4 as D4 - -schema :: D4.Schema -schema = D4.emptySchema { D4._schemaUniqueItems = Just True } - -schemaContext :: D4.SchemaContext D4.Schema -schemaContext = D4.SchemaContext - { D4._scURI = Nothing - -- ^ If your schema has relative references to other schemas - -- then you'll need to give its URI here. - , D4._scSchema = schema - } - -badData :: Value -badData = Array (V.fromList ["foo", "foo"]) - -example :: IO () -example = do - -- Since we know our schema doesn't reference any other schemas we could - -- skip this step and use @SchemaCache schema mempty@ instead. - -- - -- If we make a mistake and out schema does include references to other - -- schemas then those references will always return 'D4.RefResolution' - -- validation failures. - cache <- makeCache - - let validate = case D4.checkSchema cache schemaContext of - Left _ -> error "Not a valid schema." - Right f -> f - - case validate badData of - [] -> error "We validated bad data." - [D4.Failure D4.UniqueItems _ _] -> putStrLn "Success." - _ -> error "We got a different failure than expected." - - where - makeCache :: IO (D4.SchemaCache D4.Schema) - makeCache = do - -- A HashMap of URIs (in the form of Text) to schemas. - let currentlyStoredSchemas = H.empty - res <- D4.fetchReferencedSchemas currentlyStoredSchemas schemaContext - case res of - Left _ -> error "Couldn't fetch referenced schemas." - Right cache -> return cache diff --git a/hjsonschema.cabal b/hjsonschema.cabal --- a/hjsonschema.cabal +++ b/hjsonschema.cabal @@ -1,5 +1,5 @@ name: hjsonschema -version: 0.9.0.0 +version: 0.10.0.0 synopsis: JSON Schema library homepage: https://github.com/seagreen/hjsonschema license: MIT @@ -11,10 +11,11 @@ cabal-version: >=1.10 tested-with: GHC == 7.8.4, GHC == 7.10.2 extra-source-files: changelog.txt - draft4.json + JSON-Schema-Test-Suite/remotes/*.json JSON-Schema-Test-Suite/tests/draft4/*.json README.md - tests/Shared.hs + src/draft4.json + test/Local/*.json library hs-source-dirs: src @@ -44,37 +45,48 @@ , base >= 4.7 && < 4.9 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 - , file-embed >= 0.0.8 && < 0.0.10 + , file-embed >= 0.0.8 && < 0.1 + , filepath >= 1.3 && < 1.5 , hjsonpointer >= 0.3 && < 0.4 - , http-client >= 0.4.9 && < 0.5 + , http-client >= 0.4 && < 0.5 , http-types >= 0.8 && < 0.10 + , pcre-heavy >= 1.0 && < 1.1 , QuickCheck >= 2.8.1 && < 2.9 - , regexpr >= 0.5 && < 0.6 , scientific >= 0.3 && < 0.4 - , semigroups >= 0.18.0 && < 0.19 + , semigroups >= 0.18 && < 0.19 , unordered-containers >= 0.2 && < 0.3 - , text >= 1.2 && < 1.3 + , text >= 1.1 && < 1.3 , vector >= 0.10 && < 0.12 test-suite local type: exitcode-stdio-1.0 - hs-source-dirs: tests + hs-source-dirs: test + examples main-is: Local.hs - other-modules: Shared + other-modules: Local.Failure + , Local.Filesystem + , Local.Reference + , Shared + -- from ./examples: + , CustomSchema + , Full + , PrettyShowFailure + , Simple default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans default-extensions: OverloadedStrings build-depends: aeson , base , bytestring + , filepath , hjsonpointer , hjsonschema + , semigroups , text , QuickCheck , unordered-containers , vector , directory >= 1.2 && < 1.3 - , filepath >= 1.3 && < 1.5 , HUnit >= 1.2 && < 1.4 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 @@ -82,7 +94,7 @@ test-suite remote type: exitcode-stdio-1.0 - hs-source-dirs: tests + hs-source-dirs: test main-is: Remote.hs other-modules: Shared default-language: Haskell2010 @@ -92,32 +104,16 @@ , async , base , bytestring + , filepath , hjsonschema , text , vector , directory - , filepath , HUnit , tasty , tasty-hunit , wai-app-static , warp - -executable example - hs-source-dirs: examples - main-is: Main.hs - other-modules: CustomSchema - , PrettyShowFailure - , Standard - default-language: Haskell2010 - ghc-options: -Wall - build-depends: aeson - , base - , hjsonpointer - , hjsonschema - , text - , unordered-containers - , vector source-repository head type: git diff --git a/src/Data/JsonSchema/Draft4.hs b/src/Data/JsonSchema/Draft4.hs --- a/src/Data/JsonSchema/Draft4.hs +++ b/src/Data/JsonSchema/Draft4.hs @@ -4,67 +4,133 @@ module Data.JsonSchema.Draft4 ( Schema(..) , emptySchema - , checkSchema + -- * One-step validation + , HTTPValidationFailure(..) + , fetchHTTPAndValidate + , FilesystemValidationFailure(..) + , fetchFilesystemAndValidate + -- * Fetching tools - , SchemaContext(..) - , SchemaCache(..) - , fetchReferencedSchemas + , SchemaWithURI(..) + , ReferencedSchemas(..) + , HTTPFailure(..) + , referencesViaHTTP + , FilesystemFailure(..) + , referencesViaFilesystem -- * Failure - , Failure(..) + , Invalid + , FR.Failure(..) , ValidatorChain(..) -- * Other Draft 4 things exported just in case + , checkSchema , schemaValidity , IN.runValidate + , draft4Spec ) where +import Control.Applicative +import Control.Arrow (left) import Data.Aeson import qualified Data.ByteString.Lazy as LBS import Data.FileEmbed import qualified Data.HashMap.Strict as H +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as N import Data.Maybe (fromMaybe) -import Data.JsonSchema.Draft4.Failure +import Data.JsonSchema.Draft4.Failure (Invalid, ValidatorChain(..)) import qualified Data.JsonSchema.Draft4.Internal as IN import Data.JsonSchema.Draft4.Schema -import Data.JsonSchema.Fetch (SchemaCache(..), - SchemaContext(..), - URISchemaMap) +import Data.JsonSchema.Fetch (FilesystemFailure(..), + HTTPFailure(..), + ReferencedSchemas(..), + SchemaWithURI(..)) import qualified Data.JsonSchema.Fetch as FE -import Data.Validator.Reference (baseAndFragment) -import Import +import qualified Data.Validator.Failure as FR --- | Check the validity of a schema and return a function to validate data. +data HTTPValidationFailure + = HVRequest HTTPFailure + | HVSchema (NonEmpty Invalid) + | HVData (NonEmpty Invalid) + deriving Show + +fetchHTTPAndValidate + :: SchemaWithURI Schema + -> Value + -> IO (Either HTTPValidationFailure ()) +fetchHTTPAndValidate sw v = do + res <- referencesViaHTTP sw + pure (g =<< f =<< left HVRequest res) + where + f :: ReferencedSchemas Schema + -> Either HTTPValidationFailure (Value -> [Invalid]) + f references = left HVSchema (checkSchema references sw) + + g :: (Value -> [Invalid]) -> Either HTTPValidationFailure () + g validate = case N.nonEmpty (validate v) of + Nothing -> Right () + Just failures -> Left (HVData failures) + +data FilesystemValidationFailure + = FVRead FilesystemFailure + | FVSchema (NonEmpty Invalid) + | FVData (NonEmpty Invalid) + deriving Show + +fetchFilesystemAndValidate + :: SchemaWithURI Schema + -> Value + -> IO (Either FilesystemValidationFailure ()) +fetchFilesystemAndValidate sw v = do + res <- referencesViaFilesystem sw + pure (g =<< f =<< left FVRead res) + where + f :: ReferencedSchemas Schema + -> Either FilesystemValidationFailure (Value -> [Invalid]) + f references = left FVSchema (checkSchema references sw) + + g :: (Value -> [Invalid]) -> Either FilesystemValidationFailure () + g validate = case N.nonEmpty (validate v) of + Nothing -> Right () + Just failures -> Left (FVData failures) + +-- | Check the that a schema itself is valid. +-- +-- Return a function to validate data. checkSchema - :: SchemaCache Schema - -> SchemaContext Schema - -> Either [Failure] (Value -> [Failure]) -checkSchema sg sc = - case schemaValidity (_scSchema sc) of - [] -> Right (IN.runValidate sg sc) - es -> Left es + :: ReferencedSchemas Schema + -> SchemaWithURI Schema + -> Either (NonEmpty Invalid) (Value -> [Invalid]) +checkSchema referenced schemaWithURI = + case N.nonEmpty . schemaValidity . _swSchema $ schemaWithURI of + Nothing -> Right (IN.runValidate referenced schemaWithURI) + Just failures -> Left failures -fetchReferencedSchemas - :: URISchemaMap Schema - -> SchemaContext Schema - -> IO (Either Text (SchemaCache Schema)) -fetchReferencedSchemas = - FE.fetchReferencedSchemas IN.embedded _schemaId _schemaRef +draft4Spec :: FE.Spec Schema +draft4Spec = FE.Spec IN.embedded _schemaId _schemaRef --- | In normal situations just use 'checkSchema', which is a combination of --- 'schemaValidity' and 'runValidate'. -schemaValidity :: Schema -> [Failure] -schemaValidity = IN.runValidate cache (SchemaContext Nothing d4) . toJSON +referencesViaHTTP + :: SchemaWithURI Schema + -> IO (Either HTTPFailure (ReferencedSchemas Schema)) +referencesViaHTTP = FE.referencesViaHTTP' draft4Spec + +referencesViaFilesystem + :: SchemaWithURI Schema + -> IO (Either FilesystemFailure (ReferencedSchemas Schema)) +referencesViaFilesystem = FE.referencesViaFilesystem' draft4Spec + +-- | Check that a schema itself is valid. +schemaValidity :: Schema -> [Invalid] +schemaValidity = IN.runValidate referenced (SchemaWithURI d4 Nothing) . toJSON where d4 :: Schema d4 = fromMaybe (error "Schema decode failed (this should never happen)") - . decode . LBS.fromStrict $ $(embedFile "draft4.json") + . decode . LBS.fromStrict $ $(embedFile "src/draft4.json") - -- @fst . baseAndFragment@ is necessary to remove the trailing "#", - -- otherwise cache lookups to resolve internal references will fail. - cache :: SchemaCache Schema - cache = SchemaCache d4 $ case _schemaId d4 >>= fst . baseAndFragment of - Nothing -> mempty - Just uri -> H.singleton uri d4 + referenced :: ReferencedSchemas Schema + referenced = ReferencedSchemas + d4 + (H.singleton "http://json-schema.org/draft-04/schema" d4) diff --git a/src/Data/JsonSchema/Draft4/Failure.hs b/src/Data/JsonSchema/Draft4/Failure.hs --- a/src/Data/JsonSchema/Draft4/Failure.hs +++ b/src/Data/JsonSchema/Draft4/Failure.hs @@ -1,24 +1,9 @@ module Data.JsonSchema.Draft4.Failure where -import qualified Data.Aeson.Pointer as P - import qualified Data.Validator.Failure as FR -import Import --- | A version of 'FR.Failure' specialized for JSON Schema Draft 4. -data Failure = Failure - -- NOTE: We use a data type here instead of a newtype to provide a cleaner - -- API for those importing only 'Data.JsonSchema.Draft4' (which should be - -- the vast majority of users). Downsides: slower and hacky. I'd appreciate - -- feedback on this. - { _failureValidatorsCalled :: !ValidatorChain - , _failureFinalValidator :: !Value - , _failureOffendingData :: !P.Pointer - } deriving (Eq, Show) - -specializeForDraft4 :: FR.Failure ValidatorChain -> Failure -specializeForDraft4 (FR.Failure a b c) = Failure a b c +type Invalid = FR.Failure ValidatorChain data ValidatorChain = MultipleOf diff --git a/src/Data/JsonSchema/Draft4/Internal.hs b/src/Data/JsonSchema/Draft4/Internal.hs --- a/src/Data/JsonSchema/Draft4/Internal.hs +++ b/src/Data/JsonSchema/Draft4/Internal.hs @@ -10,8 +10,8 @@ import Data.JsonSchema.Draft4.Failure import Data.JsonSchema.Draft4.Schema -import Data.JsonSchema.Fetch (SchemaCache(..), - SchemaContext(..)) +import Data.JsonSchema.Fetch (ReferencedSchemas(..), + SchemaWithURI(..)) import qualified Data.Validator.Draft4.Any as AN import qualified Data.Validator.Draft4.Array as AR import qualified Data.Validator.Draft4.Number as NU @@ -19,7 +19,7 @@ import qualified Data.Validator.Draft4.String as ST import Data.Validator.Failure (modFailure, setFailure) import qualified Data.Validator.Failure as FR -import Data.Validator.Reference (newResolutionScope) +import Data.Validator.Reference (updateResolutionScope) import Import -- For GHCs before 7.10: @@ -71,28 +71,15 @@ checkDependency (OB.SchemaDependency s) = Just s -------------------------------------------------- --- * Validation (Exported from 'Data.JsonSchema.Draft4') --------------------------------------------------- - --- | In normal situations just use 'checkSchema', which is a combination of --- 'schemaValidity' and 'runValidate'. -runValidate - :: SchemaCache Schema - -> SchemaContext Schema - -> Value - -> [Failure] -runValidate = (fmap.fmap.fmap.fmap) specializeForDraft4 validateAny - --------------------------------------------------- -- * Validation (Main internal functions) -------------------------------------------------- -validateAny - :: SchemaCache Schema - -> SchemaContext Schema +runValidate + :: ReferencedSchemas Schema + -> SchemaWithURI Schema -> Value - -> [FR.Failure ValidatorChain] -validateAny cache sc x = concat + -> [Invalid] +runValidate referenced sw x = concat [ f _schemaEnum (setFailure Enum) (fmap maybeToList . AN.enumVal) , f _schemaType (setFailure TypeValidator) (fmap maybeToList . AN.typeVal) , f _schemaAllOf (modFailure AllOf) (AN.allOf recurse) @@ -102,48 +89,48 @@ , refFailures ] <> specificValidators where - specificValidators :: [FR.Failure ValidatorChain] + specificValidators :: [Invalid] specificValidators = case x of - Number y -> validateNumber (_scSchema sc) y - String y -> validateString (_scSchema sc) y - Array y -> validateArray cache sc y - Object y -> validateObject cache sc y + Number y -> validateNumber (_swSchema sw) y + String y -> validateString (_swSchema sw) y + Array y -> validateArray referenced sw y + Object y -> validateObject referenced sw y _ -> mempty - f = runSingle (_scSchema sc) x + f = runSingle (_swSchema sw) x - recurse = descendNextLevel cache sc + recurse = descendNextLevel referenced sw -- Since the results of the 'AN.ref' validator are fairly complicated [1] -- it's simpler not to use our 'f' helper function for it. -- -- [1] A list of errors wrapped in a 'Maybe' where 'Nothing' represents -- if resolving the reference itself failed. - refFailures :: [FR.Failure ValidatorChain] + refFailures :: [Invalid] refFailures = - case _schemaRef (_scSchema sc) of + case _schemaRef (_swSchema sw) of Nothing -> mempty Just reference -> - maybe [FR.Failure RefResolution (toJSON reference) mempty] + maybe [FR.Invalid RefResolution (toJSON reference) mempty] (fmap (modFailure Ref)) $ AN.ref scope getReference - (\a b -> validateAny cache (SchemaContext a b)) + (\a b -> runValidate referenced (SchemaWithURI b a)) reference x where scope :: Maybe Text - scope = newResolutionScope (_scURI sc) (_schemaId (_scSchema sc)) + scope = updateResolutionScope (_swURI sw) (_schemaId (_swSchema sw)) getReference :: Maybe Text -> Maybe Schema - getReference Nothing = Just (_startingSchema cache) - getReference (Just t) = H.lookup t (_cachedSchemas cache) + getReference Nothing = Just (_rsStarting referenced) + getReference (Just t) = H.lookup t (_rsSchemaMap referenced) validateString :: Schema -> Text - -> [FR.Failure ValidatorChain] + -> [Invalid] validateString schema x = concat [ f _schemaMaxLength (setFailure MaxLength) (fmap maybeToList . ST.maxLength) , f _schemaMinLength (setFailure MinLength) (fmap maybeToList . ST.minLength) @@ -155,7 +142,7 @@ validateNumber :: Schema -> Scientific - -> [FR.Failure ValidatorChain] + -> [Invalid] validateNumber schema x = concat [ f _schemaMultipleOf (setFailure MultipleOf) (fmap maybeToList . NU.multipleOf) , f _schemaMaximum @@ -179,11 +166,11 @@ fMin NU.ExclusiveMinimum = ExclusiveMinimum validateArray - :: SchemaCache Schema - -> SchemaContext Schema + :: ReferencedSchemas Schema + -> SchemaWithURI Schema -> Vector Value - -> [FR.Failure ValidatorChain] -validateArray cache (SchemaContext mUri schema) x = concat + -> [Invalid] +validateArray referenced (SchemaWithURI schema mUri) x = concat [ f _schemaMaxItems (setFailure MaxItems) (fmap maybeToList . AR.maxItems) , f _schemaMinItems (setFailure MinItems) (fmap maybeToList . AR.minItems) , f _schemaUniqueItems (setFailure UniqueItems) (fmap maybeToList . AR.uniqueItems) @@ -194,18 +181,18 @@ where f = runSingle schema x - recurse = descendNextLevel cache (SchemaContext mUri schema) + recurse = descendNextLevel referenced (SchemaWithURI schema mUri) fItems (AR.Items err) = Items err - fItems AR.AdditionalItemsBoolFailure = AdditionalItemsBool - fItems (AR.AdditionalItemsObjectFailure err) = AdditionalItemsObject err + fItems AR.AdditionalItemsBoolInvalid = AdditionalItemsBool + fItems (AR.AdditionalItemsObjectInvalid err) = AdditionalItemsObject err validateObject - :: SchemaCache Schema - -> SchemaContext Schema + :: ReferencedSchemas Schema + -> SchemaWithURI Schema -> HashMap Text Value - -> [FR.Failure ValidatorChain] -validateObject cache (SchemaContext mUri schema) x = concat + -> [Invalid] +validateObject referenced (SchemaWithURI schema mUri) x = concat [ f _schemaMaxProperties (setFailure MaxProperties) (fmap maybeToList . OB.maxProperties) , f _schemaMinProperties (setFailure MinProperties) (fmap maybeToList . OB.minProperties) , f _schemaRequired (setFailure Required) (fmap maybeToList . OB.required) @@ -232,49 +219,49 @@ where f = runSingle schema x - recurse = descendNextLevel cache (SchemaContext mUri schema) + recurse = descendNextLevel referenced (SchemaWithURI schema mUri) - fDeps (OB.SchemaDependencyFailure err) = SchemaDependency err - fDeps OB.PropertyDependencyFailure = PropertyDependency + fDeps (OB.SchemaDependencyInvalid err) = SchemaDependency err + fDeps OB.PropertyDependencyInvalid = PropertyDependency - fProp (OB.PropertiesFailure err) = Properties err - fProp (OB.PropPatternFailure err) = PatternProperties err - fProp (OB.PropAdditionalFailure a) = + fProp (OB.PropertiesInvalid err) = Properties err + fProp (OB.PropPatternInvalid err) = PatternProperties err + fProp (OB.PropAdditionalInvalid a) = case a of - OB.APBoolFailure -> AdditionalPropertiesBool - OB.APObjectFailure err -> AdditionalPropertiesObject err + OB.APBoolInvalid -> AdditionalPropertiesBool + OB.APObjectInvalid err -> AdditionalPropertiesObject err - fPatProp (OB.PPFailure err) = PatternProperties err - fPatProp (OB.PPAdditionalPropertiesFailure a) = + fPatProp (OB.PPInvalid err) = PatternProperties err + fPatProp (OB.PPAdditionalPropertiesInvalid a) = case a of - OB.APBoolFailure -> AdditionalPropertiesBool - OB.APObjectFailure err -> AdditionalPropertiesObject err + OB.APBoolInvalid -> AdditionalPropertiesBool + OB.APObjectInvalid err -> AdditionalPropertiesObject err - fAddProp OB.APBoolFailure = AdditionalPropertiesBool - fAddProp (OB.APObjectFailure err) = AdditionalItemsObject err + fAddProp OB.APBoolInvalid = AdditionalPropertiesBool + fAddProp (OB.APObjectInvalid err) = AdditionalItemsObject err -------------------------------------------------- -- * Validation (Internal utils) -------------------------------------------------- descendNextLevel - :: SchemaCache Schema - -> SchemaContext Schema + :: ReferencedSchemas Schema + -> SchemaWithURI Schema -> Schema -> Value - -> [FR.Failure ValidatorChain] -descendNextLevel cache (SchemaContext mUri schema) = - validateAny cache . SchemaContext scope + -> [Invalid] +descendNextLevel referenced (SchemaWithURI schema mUri) = + runValidate referenced . flip SchemaWithURI scope where scope :: Maybe Text - scope = newResolutionScope mUri (_schemaId schema) + scope = updateResolutionScope mUri (_schemaId schema) runSingle :: Schema -> dta -> (Schema -> Maybe val) - -> (err -> FR.Failure ValidatorChain) + -> (err -> Invalid) -> (val -> dta -> [err]) - -> [FR.Failure ValidatorChain] + -> [Invalid] runSingle schema dta field modifyError validate = maybe mempty (\val -> modifyError <$> validate val dta) (field schema) diff --git a/src/Data/JsonSchema/Fetch.hs b/src/Data/JsonSchema/Fetch.hs --- a/src/Data/JsonSchema/Fetch.hs +++ b/src/Data/JsonSchema/Fetch.hs @@ -2,22 +2,34 @@ module Data.JsonSchema.Fetch where -import Control.Exception (SomeException(..), catch) +import Control.Arrow (left) +import Control.Exception (catch) import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as H import qualified Data.Text as T import Network.HTTP.Client -import Data.Validator.Reference (isRemoteReference, - newResolutionScope, - resolveReference) +import Data.Validator.Reference (resolveReference, + updateResolutionScope) import Import -- For GHCs before 7.10: import Prelude hiding (concat, sequence) -data SchemaContext schema = SchemaContext - { _scURI :: !(Maybe Text) +-------------------------------------------------- +-- * Types +-------------------------------------------------- + +data Spec schema = Spec + { _ssEmbedded :: schema -> [schema] + , _ssGetId :: schema -> Maybe Text + , _ssGetRef :: schema -> Maybe Text + } + +data SchemaWithURI schema = SchemaWithURI + { _swSchema :: !schema + , _swURI :: !(Maybe Text) -- ^ Must not include a URI fragment, e.g. use -- "http://example.com/foo" not "http://example.com/foo#bar". -- @@ -26,108 +38,136 @@ -- when resolving references contained in the schema. -- TODO: Make the no URI fragment requirement unnecessary. - - , _scSchema :: !schema } deriving (Eq, Show) -- | Keys are URIs (without URI fragments). type URISchemaMap schema = HashMap Text schema -data SchemaCache schema = SchemaCache - { _startingSchema :: !schema +data ReferencedSchemas schema = ReferencedSchemas + { _rsStarting :: !schema -- ^ Used to resolve relative references. - , _cachedSchemas :: !(URISchemaMap schema) + , _rsSchemaMap :: !(URISchemaMap schema) } deriving (Eq, Show) +-------------------------------------------------- +-- * Fetch via HTTP +-------------------------------------------------- + +data HTTPFailure + = HTTPParseFailure Text + | HTTPRequestFailure HttpException + deriving Show + -- | Take a schema. Retrieve every document either it or its subschemas --- include via the "$ref" keyword. Load a 'SchemaCache' out with them. -fetchReferencedSchemas +-- include via the "$ref" keyword. +referencesViaHTTP' :: forall schema. FromJSON schema - => (schema -> [schema]) - -> (schema -> Maybe Text) - -> (schema -> Maybe Text) - -> URISchemaMap schema - -> SchemaContext schema - -> IO (Either Text (SchemaCache schema)) -fetchReferencedSchemas embedded getId getRef cache sc = do + => Spec schema + -> SchemaWithURI schema + -> IO (Either HTTPFailure (ReferencedSchemas schema)) +referencesViaHTTP' spec sw = do manager <- newManager defaultManagerSettings - catch (Right <$> f manager) handler + let f = referencesMethodAgnostic (get manager) spec sw + catch (left HTTPParseFailure <$> f) handler where - f manager = fetchReferencedSchemas' embedded getId getRef - (simpleGET manager) cache sc + get :: Manager -> Text -> IO LBS.ByteString + get man url = do + request <- parseUrl (T.unpack url) + responseBody <$> httpLbs request man - handler :: SomeException -> IO (Either Text (SchemaCache schema)) - handler e = pure . Left . T.pack . show $ e + handler + :: HttpException + -> IO (Either HTTPFailure (ReferencedSchemas schema)) + handler = pure . Left . HTTPRequestFailure --- | Based on 'Network.Http.Conduit.simpleHttp' from http-conduit. -simpleGET :: Manager -> Text -> IO LBS.ByteString -simpleGET man url = do - req <- parseUrl (T.unpack url) - responseBody <$> httpLbs req { requestHeaders = ("Connection", "close") - : requestHeaders req - } man +-------------------------------------------------- +-- * Fetch via Filesystem +-------------------------------------------------- +data FilesystemFailure + = FSParseFailure Text + | FSReadFailure IOError + deriving Show + +referencesViaFilesystem' + :: forall schema. FromJSON schema + => Spec schema + -> SchemaWithURI schema + -> IO (Either FilesystemFailure (ReferencedSchemas schema)) +referencesViaFilesystem' spec sw = catch (left FSParseFailure <$> f) handler + where + f :: IO (Either Text (ReferencedSchemas schema)) + f = referencesMethodAgnostic readFile' spec sw + + readFile' :: Text -> IO LBS.ByteString + readFile' = fmap LBS.fromStrict . BS.readFile . T.unpack + + handler + :: IOError + -> IO (Either FilesystemFailure (ReferencedSchemas schema)) + handler = pure . Left . FSReadFailure + +-------------------------------------------------- +-- * Method Agnostic Fetching Tools +-------------------------------------------------- + -- | A version of 'fetchReferencedSchema's where the function to fetch -- schemas is provided by the user. This allows restrictions to be added, -- e.g. rejecting non-local URIs. -fetchReferencedSchemas' +referencesMethodAgnostic :: forall schema. FromJSON schema - => (schema -> [schema]) - -> (schema -> Maybe Text) - -> (schema -> Maybe Text) - -> (Text -> IO LBS.ByteString) + => (Text -> IO LBS.ByteString) + -> Spec schema + -> SchemaWithURI schema + -> IO (Either Text (ReferencedSchemas schema)) +referencesMethodAgnostic fetchRef spec sw = + (fmap.fmap) (ReferencedSchemas (_swSchema sw)) + (foldFunction fetchRef spec mempty sw) + +foldFunction + :: forall schema. FromJSON schema + => (Text -> IO LBS.ByteString) + -> Spec schema -> URISchemaMap schema - -> SchemaContext schema - -> IO (SchemaCache schema) -fetchReferencedSchemas' embedded getId getRef fetchRef cache sc = do - let startingCache = case _scURI sc of - Nothing -> cache - Just uri -> H.insert uri (_scSchema sc) cache - SchemaCache (_scSchema sc) <$> foldlM fetchRecursively - startingCache - (includeSubschemas embedded getId sc) + -> SchemaWithURI schema + -> IO (Either Text (URISchemaMap schema)) +foldFunction fetchRef spec@(Spec _ _ getRef) referenced sw = + foldlM f (Right referenced) (includeSubschemas spec sw) where - fetchRecursively - :: URISchemaMap schema - -> SchemaContext schema - -> IO (URISchemaMap schema) - fetchRecursively g (SchemaContext mUri schema) = do - -- Resolving the new scope is necessary here because of situations - -- like this: - -- - -- { - -- "id": "http://localhost:1234/", - -- "items": { - -- "id": "folder/", - -- "items": {"$ref": "folderInteger.json"} - -- } - -- } - let scope = newResolutionScope mUri (getId schema) - case resolveReference scope <$> getRef schema of - Just (Just uri,_) -> - if not (isRemoteReference uri) || H.member uri g - then pure g - else do - bts <- fetchRef uri - case eitherDecode bts of - Left e -> ioError (userError e) - Right schm -> _cachedSchemas <$> - fetchReferencedSchemas' embedded getId getRef fetchRef - g (SchemaContext (Just uri) schm) - _ -> pure g + f :: Either Text (URISchemaMap schema) + -> SchemaWithURI schema + -> IO (Either Text (URISchemaMap schema)) + f (Left e) _ = pure (Left e) + f (Right g) (SchemaWithURI schema mUri) = + case newRef of + Nothing -> pure (Right g) + Just uri -> do + bts <- fetchRef uri + case eitherDecode bts of + Left e -> pure . Left . T.pack $ e + Right schm -> foldFunction fetchRef spec (H.insert uri schm g) + (SchemaWithURI schm (Just uri)) + where + newRef :: Maybe Text + newRef + | Just (Just uri,_) <- resolveReference mUri <$> getRef schema + = case H.lookup uri g of + Nothing -> Just uri + Just _ -> Nothing + | otherwise = Nothing -- | Return the schema passed in as an argument, as well as every -- subschema contained within it. includeSubschemas :: forall schema. - (schema -> [schema]) - -> (schema -> Maybe Text) - -> SchemaContext schema - -> [SchemaContext schema] -includeSubschemas embedded getId (SchemaContext mUri schema) = - SchemaContext mUri schema - : (includeSubschemas embedded getId =<< subSchemas) + Spec schema + -> SchemaWithURI schema + -> [SchemaWithURI schema] +includeSubschemas spec@(Spec embedded getId _) (SchemaWithURI schema mUri) = + SchemaWithURI schema mUri + : (includeSubschemas spec =<< subSchemas) where - subSchemas :: [SchemaContext schema] - subSchemas = SchemaContext (newResolutionScope mUri (getId schema)) - <$> embedded schema + subSchemas :: [SchemaWithURI schema] + subSchemas = + (\a -> SchemaWithURI a (updateResolutionScope mUri (getId schema))) + <$> embedded schema diff --git a/src/Data/Validator/Draft4/Any.hs b/src/Data/Validator/Draft4/Any.hs --- a/src/Data/Validator/Draft4/Any.hs +++ b/src/Data/Validator/Draft4/Any.hs @@ -12,11 +12,11 @@ import Data.Validator.Failure import Data.Validator.Utils -import Data.Validator.Reference +import Data.Validator.Reference (resolveFragment, resolveReference) import Import -- For GHCs before 7.10: -import Prelude hiding (any) +import Prelude hiding (any, elem) -------------------------------------------------- -- * $ref @@ -81,11 +81,10 @@ enumVal :: EnumVal -> Value -> Maybe (Failure ()) enumVal (EnumVal vs) x - | null vs = Nothing | not (allUniqueValues' vs) = Nothing | x `elem` vs = Nothing | otherwise = - Just $ Failure () (toJSON (NonEmpty' vs)) mempty + Just $ Invalid () (toJSON (NonEmpty' vs)) mempty -------------------------------------------------- -- * type @@ -115,7 +114,7 @@ isJsonType :: Value -> Set Text -> Maybe (Failure ()) isJsonType x ts - | S.null (S.intersection okTypes ts) = Just (Failure () (toJSON ts) mempty) + | S.null (S.intersection okTypes ts) = Just (Invalid () (toJSON ts) mempty) | otherwise = Nothing where okTypes :: Set Text @@ -150,7 +149,7 @@ -> Maybe (Failure ()) anyOf f subSchemas x | any null (flip f x <$> subSchemas) = Nothing - | otherwise = Just $ Failure () (toJSON (NonEmpty' subSchemas)) mempty + | otherwise = Just $ Invalid () (toJSON (NonEmpty' subSchemas)) mempty oneOf :: forall err schema. ToJSON schema @@ -160,7 +159,7 @@ -> Maybe (Failure ()) oneOf f subSchemas x | length successes == 1 = Nothing - | otherwise = Just $ Failure () + | otherwise = Just $ Invalid () (toJSON (NonEmpty' subSchemas)) mempty where @@ -175,5 +174,5 @@ -> Maybe (Failure ()) notVal f schema x = case f schema x of - [] -> Just (Failure () (toJSON schema) mempty) + [] -> Just (Invalid () (toJSON schema) mempty) _ -> Nothing diff --git a/src/Data/Validator/Draft4/Array.hs b/src/Data/Validator/Draft4/Array.hs --- a/src/Data/Validator/Draft4/Array.hs +++ b/src/Data/Validator/Draft4/Array.hs @@ -15,30 +15,30 @@ maxItems :: Int -> Vector Value -> Maybe (Failure ()) maxItems n xs | n < 0 = Nothing - | V.length xs > n = Just (Failure () (toJSON n) mempty) + | V.length xs > n = Just (Invalid () (toJSON n) mempty) | otherwise = Nothing -- | The spec requires "minItems" to be non-negative. minItems :: Int -> Vector Value -> Maybe (Failure ()) minItems n xs | n < 0 = Nothing - | V.length xs < n = Just (Failure () (toJSON n) mempty) + | V.length xs < n = Just (Invalid () (toJSON n) mempty) | otherwise = Nothing uniqueItems :: Bool -> Vector Value -> Maybe (Failure ()) uniqueItems True xs | allUniqueValues xs = Nothing - | otherwise = Just (Failure () (Bool True) mempty) + | otherwise = Just (Invalid () (Bool True) mempty) uniqueItems False _ = Nothing -------------------------------------------------- -- * items -------------------------------------------------- -data ItemsFailure err +data ItemsInvalid err = Items err - | AdditionalItemsBoolFailure - | AdditionalItemsObjectFailure err + | AdditionalItemsBoolInvalid + | AdditionalItemsObjectInvalid err deriving (Eq, Show) data Items schema @@ -65,10 +65,10 @@ -> Maybe (AdditionalItems schema) -> Items schema -> Vector Value - -> [Failure (ItemsFailure err)] + -> [Failure (ItemsInvalid err)] items f _ (ItemsObject subSchema) xs = zip [0..] (V.toList xs) >>= g where - g :: (Int, Value) -> [Failure (ItemsFailure err)] + g :: (Int, Value) -> [Failure (ItemsInvalid err)] g (index,x) = modFailure Items . addToPath (P.Token (T.pack (show index))) <$> f subSchema x @@ -79,15 +79,15 @@ indexedValues :: [(Int, Value)] indexedValues = zip [0..] (V.toList xs) - itemFailures :: [Failure (ItemsFailure err)] + itemFailures :: [Failure (ItemsInvalid err)] itemFailures = join (zipWith g subSchemas indexedValues) where - g :: schema -> (Int, Value) -> [Failure (ItemsFailure err)] + g :: schema -> (Int, Value) -> [Failure (ItemsInvalid err)] g schema (index,x) = modFailure Items . addToPath (P.Token (T.pack (show index))) <$> f schema x - additionalItemFailures :: [Failure (ItemsFailure err)] + additionalItemFailures :: [Failure (ItemsInvalid err)] additionalItemFailures = case mAdditional of Nothing -> mempty @@ -105,9 +105,9 @@ -- represent invalid data so they actually represent the correct -- offsets. correctIndexes - :: Failure (AdditionalItemsFailure err) - -> Failure (AdditionalItemsFailure err) - correctIndexes (Failure a b c) = Failure a b (fixIndex c) + :: Failure (AdditionalItemsInvalid err) + -> Failure (AdditionalItemsInvalid err) + correctIndexes (Invalid a b c) = Invalid a b (fixIndex c) where fixIndex :: P.Pointer -> P.Pointer fixIndex (P.Pointer (tok:toks)) = @@ -117,18 +117,18 @@ (P.Token . T.pack . show $ n + length subSchemas):toks fixIndex (P.Pointer []) = P.Pointer [] - correctName :: AdditionalItemsFailure err -> ItemsFailure err - correctName AdditionalBoolFailure = AdditionalItemsBoolFailure - correctName (AdditionalObjectFailure err) = - AdditionalItemsObjectFailure err + correctName :: AdditionalItemsInvalid err -> ItemsInvalid err + correctName AdditionalBoolInvalid = AdditionalItemsBoolInvalid + correctName (AdditionalObjectInvalid err) = + AdditionalItemsObjectInvalid err -------------------------------------------------- -- * additionalItems -------------------------------------------------- -data AdditionalItemsFailure err - = AdditionalBoolFailure - | AdditionalObjectFailure err +data AdditionalItemsInvalid err + = AdditionalBoolInvalid + | AdditionalObjectInvalid err deriving (Eq, Show) data AdditionalItems schema @@ -154,15 +154,15 @@ (schema -> Value -> [Failure err]) -> AdditionalItems schema -> Vector Value - -> [Failure (AdditionalItemsFailure err)] + -> [Failure (AdditionalItemsInvalid err)] additionalItems _ (AdditionalBool b) xs | b = mempty - | V.length xs > 0 = pure (Failure AdditionalBoolFailure (Bool b) mempty) + | V.length xs > 0 = pure (Invalid AdditionalBoolInvalid (Bool b) mempty) | otherwise = mempty additionalItems f (AdditionalObject subSchema) xs = zip [0..] (V.toList xs) >>= g where - g :: (Int, Value) -> [Failure (AdditionalItemsFailure err)] - g (index,x) = modFailure AdditionalObjectFailure + g :: (Int, Value) -> [Failure (AdditionalItemsInvalid err)] + g (index,x) = modFailure AdditionalObjectInvalid . addToPath (P.Token (T.pack (show index))) <$> f subSchema x diff --git a/src/Data/Validator/Draft4/Number.hs b/src/Data/Validator/Draft4/Number.hs --- a/src/Data/Validator/Draft4/Number.hs +++ b/src/Data/Validator/Draft4/Number.hs @@ -11,10 +11,10 @@ multipleOf :: Scientific -> Scientific -> Maybe (Failure ()) multipleOf n x | n <= 0 = Nothing - | x `mod'` n /= 0 = Just (Failure () (toJSON n) mempty) + | x `mod'` n /= 0 = Just (Invalid () (toJSON n) mempty) | otherwise = Nothing -data MaximumFailure +data MaximumInvalid = Maximum | ExclusiveMaximum deriving (Eq, Show) @@ -23,16 +23,16 @@ :: Bool -> Scientific -> Scientific - -> Maybe (Failure MaximumFailure) + -> Maybe (Failure MaximumInvalid) maximumVal exclusiveMaximum n x - | x `greaterThan` n = Just (Failure err (toJSON n) mempty) + | x `greaterThan` n = Just (Invalid err (toJSON n) mempty) | otherwise = Nothing where (greaterThan, err) = if exclusiveMaximum then ((>=), ExclusiveMaximum) else ((>), Maximum) -data MinimumFailure +data MinimumInvalid = Minimum | ExclusiveMinimum deriving (Eq, Show) @@ -41,9 +41,9 @@ :: Bool -> Scientific -> Scientific - -> Maybe (Failure MinimumFailure) + -> Maybe (Failure MinimumInvalid) minimumVal exclusiveMinimum n x - | x `lessThan` n = Just (Failure err (toJSON n) mempty) + | x `lessThan` n = Just (Invalid err (toJSON n) mempty) | otherwise = Nothing where (lessThan, err) = if exclusiveMinimum diff --git a/src/Data/Validator/Draft4/Object.hs b/src/Data/Validator/Draft4/Object.hs --- a/src/Data/Validator/Draft4/Object.hs +++ b/src/Data/Validator/Draft4/Object.hs @@ -25,14 +25,14 @@ maxProperties :: Int -> HashMap Text Value -> Maybe (Failure ()) maxProperties n x | n < 0 = Nothing - | H.size x > n = Just (Failure () (toJSON n) mempty) + | H.size x > n = Just (Invalid () (toJSON n) mempty) | otherwise = Nothing -- | The spec requires "minProperties" to be non-negative. minProperties :: Int -> HashMap Text Value -> Maybe (Failure ()) minProperties n x | n < 0 = Nothing - | H.size x < n = Just (Failure () (toJSON n) mempty) + | H.size x < n = Just (Invalid () (toJSON n) mempty) | otherwise = Nothing -------------------------------------------------- @@ -80,7 +80,7 @@ -- instead of specialized versions. | S.null ts = Nothing | H.null (H.difference hm x) = Nothing - | otherwise = Just (Failure () (toJSON ts) mempty) + | otherwise = Just (Invalid () (toJSON ts) mempty) where hm :: HashMap Text Bool hm = foldl (\b a -> H.insert a True b) mempty ts @@ -89,9 +89,9 @@ -- * dependencies -------------------------------------------------- -data DependencyFailure err - = SchemaDependencyFailure err - | PropertyDependencyFailure +data DependencyInvalid err + = SchemaDependencyInvalid err + | PropertyDependencyInvalid deriving (Eq, Show) data Dependency schema @@ -128,17 +128,17 @@ :: forall err schema. (schema -> Value -> [Failure err]) -> HashMap Text (Dependency schema) -> HashMap Text Value - -> [Failure (DependencyFailure err)] + -> [Failure (DependencyInvalid err)] dependencies f hm x = concat . fmap (uncurry g) . H.toList $ hm where - g :: Text -> Dependency schema -> [Failure (DependencyFailure err)] + g :: Text -> Dependency schema -> [Failure (DependencyInvalid err)] g k (SchemaDependency schema) | H.member k x = - modFailure SchemaDependencyFailure <$> f schema (Object x) + modFailure SchemaDependencyInvalid <$> f schema (Object x) | otherwise = mempty g k (PropertyDependency ts) | H.member k x && not allPresent = - pure $ Failure PropertyDependencyFailure + pure $ Invalid PropertyDependencyInvalid (toJSON (H.singleton k ts)) mempty | otherwise = mempty diff --git a/src/Data/Validator/Draft4/Object/Properties.hs b/src/Data/Validator/Draft4/Object/Properties.hs --- a/src/Data/Validator/Draft4/Object/Properties.hs +++ b/src/Data/Validator/Draft4/Object/Properties.hs @@ -7,7 +7,8 @@ import qualified Data.Aeson.Pointer as P import qualified Data.HashMap.Strict as H import qualified Data.Text as T -import Text.RegexPR +import Data.Text.Encoding (encodeUtf8) +import qualified Text.Regex.PCRE.Heavy as RE import Data.Validator.Failure import Import @@ -18,10 +19,10 @@ -- * properties -------------------------------------------------- -data PropertiesFailure err - = PropertiesFailure err - | PropPatternFailure err - | PropAdditionalFailure (AdditionalPropertiesFailure err) +data PropertiesInvalid err + = PropertiesInvalid err + | PropPatternInvalid err + | PropAdditionalInvalid (AdditionalPropertiesInvalid err) deriving (Eq, Show) -- | In order of what's tried: "properties", "patternProperties", @@ -33,11 +34,11 @@ -> Maybe (AdditionalProperties schema) -> HashMap Text schema -> HashMap Text Value - -> [Failure (PropertiesFailure err)] + -> [Failure (PropertiesInvalid err)] properties f mPat mAdd propertiesHm x = - fmap (modFailure PropertiesFailure) propFailures - <> fmap (modFailure PropPatternFailure) patternFailures - <> fmap (modFailure PropAdditionalFailure) additionalFailures + fmap (modFailure PropertiesInvalid) propFailures + <> fmap (modFailure PropPatternInvalid) patternFailures + <> fmap (modFailure PropAdditionalInvalid) additionalFailures where propertiesAndUnmatched :: ([Failure err], Remaining) propertiesAndUnmatched = ( failures @@ -63,7 +64,7 @@ Nothing -> remaining1 Just val -> snd . val . _unRemaining $ remaining1 - additionalFailures :: [Failure (AdditionalPropertiesFailure err)] + additionalFailures :: [Failure (AdditionalPropertiesInvalid err)] additionalFailures = case additionalProperties f <$> mAdd of Nothing -> mempty Just val -> val (_unRemaining remaining2) @@ -72,9 +73,9 @@ -- * patternProperties -------------------------------------------------- -data PatternPropertiesFailure err - = PPFailure err - | PPAdditionalPropertiesFailure (AdditionalPropertiesFailure err) +data PatternPropertiesInvalid err + = PPInvalid err + | PPAdditionalPropertiesInvalid (AdditionalPropertiesInvalid err) deriving (Eq, Show) patternProperties @@ -83,17 +84,17 @@ -> Maybe (AdditionalProperties schema) -> HashMap Text schema -> HashMap Text Value - -> [Failure (PatternPropertiesFailure err)] + -> [Failure (PatternPropertiesInvalid err)] patternProperties f mAdd patternPropertiesHm x = - fmap (modFailure PPFailure) ppFailures - <> fmap (modFailure PPAdditionalPropertiesFailure) addFailures + fmap (modFailure PPInvalid) ppFailures + <> fmap (modFailure PPAdditionalPropertiesInvalid) addFailures where patternProps :: ([Failure err], Remaining) patternProps = patternAndUnmatched f patternPropertiesHm x (ppFailures, remaining) = patternProps - addFailures :: [Failure (AdditionalPropertiesFailure err)] + addFailures :: [Failure (AdditionalPropertiesInvalid err)] addFailures = case additionalProperties f <$> mAdd of Nothing -> mempty Just val -> val (_unRemaining remaining) @@ -126,9 +127,11 @@ -> schema -> [schema] checkKey k acc r subSchema = - case matchRegexPR (T.unpack r) (T.unpack k) of - Nothing -> acc - Just _ -> pure subSchema <> acc + case RE.compileM (encodeUtf8 r) mempty of + Left _ -> acc + Right re -> if k RE.=~ re + then pure subSchema <> acc + else acc runVals :: [Failure err] @@ -146,9 +149,9 @@ -- * additionalProperties -------------------------------------------------- -data AdditionalPropertiesFailure err - = APBoolFailure - | APObjectFailure err +data AdditionalPropertiesInvalid err + = APBoolInvalid + | APObjectInvalid err deriving (Eq, Show) data AdditionalProperties schema @@ -174,14 +177,14 @@ (schema -> Value -> [Failure err]) -> AdditionalProperties schema -> HashMap Text Value - -> [Failure (AdditionalPropertiesFailure err)] + -> [Failure (AdditionalPropertiesInvalid err)] additionalProperties _ (AdditionalPropertiesBool False) x - | H.size x > 0 = pure $ Failure APBoolFailure (Bool False) mempty + | H.size x > 0 = pure $ Invalid APBoolInvalid (Bool False) mempty | otherwise = mempty additionalProperties _ (AdditionalPropertiesBool True) _ = mempty additionalProperties f (AdditionalPropertiesObject schema) x = H.toList x >>= g where - g :: (Text, Value) -> [Failure (AdditionalPropertiesFailure err)] - g (k,v) = modFailure APObjectFailure + g :: (Text, Value) -> [Failure (AdditionalPropertiesInvalid err)] + g (k,v) = modFailure APObjectInvalid . addToPath (P.Token k) <$> f schema v diff --git a/src/Data/Validator/Draft4/String.hs b/src/Data/Validator/Draft4/String.hs --- a/src/Data/Validator/Draft4/String.hs +++ b/src/Data/Validator/Draft4/String.hs @@ -3,7 +3,8 @@ import Data.Aeson import qualified Data.Text as T -import Text.RegexPR +import Data.Text.Encoding (encodeUtf8) +import qualified Text.Regex.PCRE.Heavy as RE import Data.Validator.Failure import Import @@ -12,18 +13,20 @@ maxLength :: Int -> Text -> Maybe (Failure ()) maxLength n x | n <= 0 = Nothing - | T.length x > n = Just (Failure () (toJSON n) mempty) + | T.length x > n = Just (Invalid () (toJSON n) mempty) | otherwise = Nothing -- | The spec requires "minLength" to be non-negative. minLength :: Int -> Text -> Maybe (Failure ()) minLength n x | n <= 0 = Nothing - | T.length x < n = Just (Failure () (toJSON n) mempty) + | T.length x < n = Just (Invalid () (toJSON n) mempty) | otherwise = Nothing patternVal :: Text -> Text -> Maybe (Failure ()) patternVal t x = - case matchRegexPR (T.unpack t) (T.unpack x) of - Nothing -> Just (Failure () (toJSON t) mempty) - Just _ -> Nothing + case RE.compileM (encodeUtf8 t) mempty of + Left _ -> Just (Invalid () (toJSON t) mempty) + Right re -> if x RE.=~ re + then Nothing + else Just (Invalid () (toJSON t) mempty) diff --git a/src/Data/Validator/Failure.hs b/src/Data/Validator/Failure.hs --- a/src/Data/Validator/Failure.hs +++ b/src/Data/Validator/Failure.hs @@ -23,20 +23,20 @@ -- by the validators it uses into a single error sum type for that schema. -- The schema's validate function will return a 'ValidationFailure' with -- that sum type as its type argument. -data Failure err = Failure - { _failureValidatorsCalled :: !err - , _failureFinalValidator :: !Value - , _failureOffendingData :: !P.Pointer +data Failure err = Invalid + { _invalidValidatorsCalled :: !err + , _invalidFinalValidator :: !Value + , _invalidOffendingData :: !P.Pointer } deriving (Eq, Show) setFailure :: b -> Failure a -> Failure b -setFailure e (Failure _ a b) = Failure e a b +setFailure e (Invalid _ a b) = Invalid e a b modFailure :: (a -> b) -> Failure a -> Failure b -modFailure f v@(Failure a _ _) = v { _failureValidatorsCalled = f a } +modFailure f v@(Invalid a _ _) = v { _invalidValidatorsCalled = f a } addToPath :: P.Token -> Failure a -> Failure a -addToPath tok v@(Failure _ _ a) = v { _failureOffendingData = addToken a } +addToPath tok v@(Invalid _ _ a) = v { _invalidOffendingData = addToken a } where addToken :: P.Pointer -> P.Pointer addToken (P.Pointer ts) = P.Pointer (ts <> pure tok) diff --git a/src/Data/Validator/Reference.hs b/src/Data/Validator/Reference.hs --- a/src/Data/Validator/Reference.hs +++ b/src/Data/Validator/Reference.hs @@ -1,28 +1,43 @@ +-- | JSON Reference is described here: +-- +-- +-- And is extended for JSON Schema here: +-- +-- +-- Notes on where these functions are used: +-- +-- * 'Data.JsonSchema.Fetch.includeSubschemas' uses 'updateResolutionScope'. +-- +-- * 'Data.JsonSchema.Fetch.foldFunction' uses 'resolveReference'. +-- +-- * 'Data.JsonSchema.Draft4.Internal' uses 'updateResolutionScope' +-- throughout. +-- +-- * 'Data.Validator.Draft4.Any.ref' uses 'resolveReference' and +-- 'resolveFragment'. + module Data.Validator.Reference where import qualified Data.Aeson.Pointer as P import qualified Data.Text as T import Data.Text.Encoding -import Network.HTTP.Types.URI +import Network.HTTP.Types.URI (urlDecode) +import System.FilePath ((), dropFileName) import Import type URIBase = Maybe Text type URIBaseAndFragment = (Maybe Text, Maybe Text) -newResolutionScope :: URIBase -> Maybe Text -> URIBase -newResolutionScope mScope idKeyword = - case idKeyword of - Just t -> fst . baseAndFragment $ resolveScopeAgainst mScope t - _ -> mScope +updateResolutionScope :: URIBase -> Maybe Text -> URIBase +updateResolutionScope mScope idKeyword + | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t + | otherwise = mScope resolveReference :: URIBase -> Text -> URIBaseAndFragment resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t -isRemoteReference :: Text -> Bool -isRemoteReference uri = "://" `T.isInfixOf` uri - resolveFragment :: (FromJSON schema, ToJSON schema, Show schema) => Maybe Text @@ -38,9 +53,12 @@ Success schema' -> Just schema' -------------------------------------------------- --- * Internal +-- * Helpers -------------------------------------------------- +isRemoteReference :: Text -> Bool +isRemoteReference = T.isInfixOf "://" + baseAndFragment :: Text -> URIBaseAndFragment baseAndFragment = f . T.splitOn "#" where @@ -62,6 +80,12 @@ -- but just in case a user leaves one in we want to be sure -- to cut it off before appending. smartAppend :: Text - smartAppend = case baseAndFragment scope of - (Just base,_) -> base <> t - _ -> t + smartAppend = + case baseAndFragment scope of + (Just base,_) -> + case T.unpack t of + -- We want "/foo" and "#/bar" to combine into + -- "/foo#/bar" not "/foo/#/bar". + '#':_ -> base <> t + _ -> T.pack (dropFileName (T.unpack base) T.unpack t) + _ -> t diff --git a/src/draft4.json b/src/draft4.json new file mode 100644 --- /dev/null +++ b/src/draft4.json @@ -0,0 +1,150 @@ +{ + "id": "http://json-schema.org/draft-04/schema#", + "$schema": "http://json-schema.org/draft-04/schema#", + "description": "Core schema meta-schema", + "definitions": { + "schemaArray": { + "type": "array", + "minItems": 1, + "items": { "$ref": "#" } + }, + "positiveInteger": { + "type": "integer", + "minimum": 0 + }, + "positiveIntegerDefault0": { + "allOf": [ { "$ref": "#/definitions/positiveInteger" }, { "default": 0 } ] + }, + "simpleTypes": { + "enum": [ "array", "boolean", "integer", "null", "number", "object", "string" ] + }, + "stringArray": { + "type": "array", + "items": { "type": "string" }, + "minItems": 1, + "uniqueItems": true + } + }, + "type": "object", + "properties": { + "id": { + "type": "string", + "format": "uri" + }, + "$schema": { + "type": "string", + "format": "uri" + }, + "title": { + "type": "string" + }, + "description": { + "type": "string" + }, + "default": {}, + "multipleOf": { + "type": "number", + "minimum": 0, + "exclusiveMinimum": true + }, + "maximum": { + "type": "number" + }, + "exclusiveMaximum": { + "type": "boolean", + "default": false + }, + "minimum": { + "type": "number" + }, + "exclusiveMinimum": { + "type": "boolean", + "default": false + }, + "maxLength": { "$ref": "#/definitions/positiveInteger" }, + "minLength": { "$ref": "#/definitions/positiveIntegerDefault0" }, + "pattern": { + "type": "string", + "format": "regex" + }, + "additionalItems": { + "anyOf": [ + { "type": "boolean" }, + { "$ref": "#" } + ], + "default": {} + }, + "items": { + "anyOf": [ + { "$ref": "#" }, + { "$ref": "#/definitions/schemaArray" } + ], + "default": {} + }, + "maxItems": { "$ref": "#/definitions/positiveInteger" }, + "minItems": { "$ref": "#/definitions/positiveIntegerDefault0" }, + "uniqueItems": { + "type": "boolean", + "default": false + }, + "maxProperties": { "$ref": "#/definitions/positiveInteger" }, + "minProperties": { "$ref": "#/definitions/positiveIntegerDefault0" }, + "required": { "$ref": "#/definitions/stringArray" }, + "additionalProperties": { + "anyOf": [ + { "type": "boolean" }, + { "$ref": "#" } + ], + "default": {} + }, + "definitions": { + "type": "object", + "additionalProperties": { "$ref": "#" }, + "default": {} + }, + "properties": { + "type": "object", + "additionalProperties": { "$ref": "#" }, + "default": {} + }, + "patternProperties": { + "type": "object", + "additionalProperties": { "$ref": "#" }, + "default": {} + }, + "dependencies": { + "type": "object", + "additionalProperties": { + "anyOf": [ + { "$ref": "#" }, + { "$ref": "#/definitions/stringArray" } + ] + } + }, + "enum": { + "type": "array", + "minItems": 1, + "uniqueItems": true + }, + "type": { + "anyOf": [ + { "$ref": "#/definitions/simpleTypes" }, + { + "type": "array", + "items": { "$ref": "#/definitions/simpleTypes" }, + "minItems": 1, + "uniqueItems": true + } + ] + }, + "allOf": { "$ref": "#/definitions/schemaArray" }, + "anyOf": { "$ref": "#/definitions/schemaArray" }, + "oneOf": { "$ref": "#/definitions/schemaArray" }, + "not": { "$ref": "#" } + }, + "dependencies": { + "exclusiveMaximum": [ "maximum" ], + "exclusiveMinimum": [ "minimum" ] + }, + "default": {} +} diff --git a/test/Local.hs b/test/Local.hs new file mode 100644 --- /dev/null +++ b/test/Local.hs @@ -0,0 +1,54 @@ + +module Main where + +import Control.Applicative +import Control.Monad (unless) +import Data.Aeson +import Data.List (isSuffixOf) +import Data.Monoid +import System.Directory (getDirectoryContents) +import Test.Tasty (TestTree, defaultMain, testGroup) +import qualified Test.Tasty.HUnit as HU +import Test.Tasty.QuickCheck (testProperty) + +-- Examples +import qualified CustomSchema +import qualified Full +import qualified PrettyShowFailure +import qualified Simple + +import Data.JsonSchema.Draft4 +import Local.Failure (correctPaths) +import Local.Filesystem (fetchFromFilesystem) +import Local.Reference (referenceTests) +import Shared (isLocal, readSchemaTests, toTest) + +dir :: String +dir = "JSON-Schema-Test-Suite/tests/draft4" + +main :: IO () +main = do + filenames <- filter isLocal . filter (".json" `isSuffixOf`) <$> getDirectoryContents dir + ts <- readSchemaTests dir filenames + defaultMain . testGroup "Tests not requiring an HTTP server" $ + testGroup "Check that examples compile and don't throw errors" exampleTests + : testGroup "QuickCheck tests" quickCheckTests + : testGroup "Report the path to invalid data correctly" correctPaths + : testGroup "Test the referencesViaFilesystem function" fetchFromFilesystem + : testGroup "Test the Reference module" referenceTests + : fmap toTest ts + +quickCheckTests :: [TestTree] +quickCheckTests = + [testProperty "Invert schemas through JSON without change" invertSchema] + where + invertSchema :: Schema -> Bool + invertSchema a = Just a == decode (encode a) + +exampleTests :: [TestTree] +exampleTests = + [ HU.testCase "CustomSchema example" CustomSchema.example + , HU.testCase "Full example" Full.example + , HU.testCase "PrettyShowFailure example" PrettyShowFailure.example + , HU.testCase "Simple example" Simple.example + ] diff --git a/test/Local/Failure.hs b/test/Local/Failure.hs new file mode 100644 --- /dev/null +++ b/test/Local/Failure.hs @@ -0,0 +1,55 @@ + +module Local.Failure where + +import Data.Aeson +import qualified Data.Aeson.Pointer as P +import Data.Monoid +import Test.Tasty (TestTree) +import qualified Test.Tasty.HUnit as HU + +import Data.JsonSchema.Draft4 +import qualified Data.Validator.Draft4 as VA + +correctPaths :: [TestTree] +correctPaths = + [ HU.testCase "Items object" itemsObject + , HU.testCase "Items array" itemsArray + ] + +itemsObject :: IO () +itemsObject = HU.assertEqual "Path to invalid data" + (P.Pointer [P.Token "0"]) + (_invalidOffendingData failure) + where + [failure] = runValidate (ReferencedSchemas schema mempty) + sw (toJSON [[True, True]]) + + schema :: Schema + schema = emptySchema + { _schemaItems = Just (VA.ItemsObject (emptySchema { _schemaUniqueItems = Just True })) + } + + sw :: SchemaWithURI Schema + sw = SchemaWithURI + { _swSchema = schema + , _swURI = Nothing + } + +itemsArray :: IO () +itemsArray = HU.assertEqual "Path to invalid data" + (P.Pointer [P.Token "0"]) + (_invalidOffendingData failure) + where + [failure] = runValidate (ReferencedSchemas schema mempty) + sw (toJSON [[True, True]]) + + schema :: Schema + schema = emptySchema + { _schemaItems = Just (VA.ItemsArray [emptySchema { _schemaUniqueItems = Just True }]) + } + + sw :: SchemaWithURI Schema + sw = SchemaWithURI + { _swSchema = schema + , _swURI = Nothing + } diff --git a/test/Local/Filesystem.hs b/test/Local/Filesystem.hs new file mode 100644 --- /dev/null +++ b/test/Local/Filesystem.hs @@ -0,0 +1,56 @@ + +module Local.Filesystem where + +import Control.Applicative +import Data.Aeson +import Data.Monoid +import Test.Tasty (TestTree) +import qualified Test.Tasty.HUnit as HU +import Data.Text (Text) + +import Data.JsonSchema.Draft4 + +fetchFromFilesystem :: [TestTree] +fetchFromFilesystem = + [ HU.testCase + "readFile exceptions are turned into Lefts" + readFileExceptions + + , HU.testCase + "Relative reference to local file" + (resolve "test/Local/schema.json") + , HU.testCase + "Chained relative references to local files" + (resolve "./test/Local/schema-with-ref.json") + ] + +readFileExceptions :: IO () +readFileExceptions = do + res <- referencesViaFilesystem (SchemaWithURI schema Nothing) + case res of + Left (FSReadFailure _) -> pure () + a -> error (msg <> show a) + where + schema :: Schema + schema = emptySchema { _schemaRef = Just "does-not-exist.json" } + + msg :: String + msg = "expected referencesViaFilesystem to return ReadFailure," + <> " instead got: " + +-- * Helpers + +resolve :: Text -> IO () +resolve ref = do + let schema = emptySchema { _schemaRef = Just ref } + res <- fetchFilesystemAndValidate (SchemaWithURI schema Nothing) badData + case res of + Left (FVData _) -> pure () + a -> error (msg <> show a) + where + badData :: Value + badData = toJSON [True, True] + + msg :: String + msg = "expected fetchFilesystemAndValidate to return" + <> " Left (FVData [_]), instead got: " diff --git a/test/Local/Reference.hs b/test/Local/Reference.hs new file mode 100644 --- /dev/null +++ b/test/Local/Reference.hs @@ -0,0 +1,51 @@ + +module Local.Reference where + +import Test.Tasty (TestTree) +import qualified Test.Tasty.HUnit as HU + +import Data.Validator.Reference + +referenceTests :: [TestTree] +referenceTests = + [ HU.testCase "updateResolutionScope test cases" updateResolutionScopeTests + , HU.testCase "resolveReference test cases" resolveReferenceTests + ] + +updateResolutionScopeTests :: IO () +updateResolutionScopeTests = do + HU.assertEqual + "case 1 result" + Nothing + (updateResolutionScope Nothing Nothing) + HU.assertEqual + "case 2 result" + Nothing + (updateResolutionScope Nothing (Just "#")) + HU.assertEqual + "case 3 result" + (Just "foo") + (updateResolutionScope Nothing (Just "foo")) + HU.assertEqual + "case 4 result" + (Just "/./bar") -- TODO: Normalize after updateResolutionScope. + (updateResolutionScope (Just "/foo") (Just "./bar")) + +resolveReferenceTests :: IO () +resolveReferenceTests = do + HU.assertEqual + "case 1 result" + (Just "/bar", Nothing) + (resolveReference (Just "/foo") "bar") + HU.assertEqual + "case 2 result" + (Just "/baz", Nothing) + (resolveReference (Just "/foo/bar") "/baz") + HU.assertEqual + "case 3 result" + (Nothing, Just "/bar") + (resolveReference Nothing "#/bar") + HU.assertEqual + "case 4 result" + (Just "/foo", Just "/bar") + (resolveReference (Just "/foo") "#/bar") diff --git a/test/Local/schema-with-ref.json b/test/Local/schema-with-ref.json new file mode 100644 --- /dev/null +++ b/test/Local/schema-with-ref.json @@ -0,0 +1,3 @@ +{ + "$ref": "./schema.json" +} diff --git a/test/Local/schema.json b/test/Local/schema.json new file mode 100644 --- /dev/null +++ b/test/Local/schema.json @@ -0,0 +1,3 @@ +{ + "uniqueItems": true +} diff --git a/test/Remote.hs b/test/Remote.hs new file mode 100644 --- /dev/null +++ b/test/Remote.hs @@ -0,0 +1,26 @@ +module Main where + +import Control.Applicative +import Control.Concurrent.Async (withAsync) +import Data.List (isSuffixOf) +import Network.Wai.Application.Static (defaultFileServerSettings, + staticApp) +import Network.Wai.Handler.Warp (run) +import System.Directory (getDirectoryContents) +import Test.Tasty (defaultMain, testGroup) + +import Shared (isLocal, readSchemaTests, + toTest) + +dir :: String +dir = "JSON-Schema-Test-Suite/tests/draft4" + +main :: IO () +main = withAsync serve $ \_ -> do + filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`) + <$> getDirectoryContents dir + ts <- readSchemaTests dir filenames + defaultMain . testGroup "Tests that run an HTTP server" $ toTest <$> ts + +serve :: IO () +serve = run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes" diff --git a/test/Shared.hs b/test/Shared.hs new file mode 100644 --- /dev/null +++ b/test/Shared.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Shared where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.Aeson.TH +import qualified Data.ByteString.Lazy as LBS +import Data.Char (toLower) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics +import System.FilePath (()) +import Test.Tasty (TestTree) +import qualified Test.Tasty.HUnit as HU + +import qualified Data.JsonSchema.Draft4 as D4 + +isLocal :: String -> Bool +isLocal file = (file /= "definitions.json") + && (file /= "ref.json") + && (file /= "refRemote.json") + +data SchemaTest = SchemaTest + { _stDescription :: Text + , _stSchema :: D4.Schema + , _stCases :: [SchemaTestCase] + } + +data SchemaTestCase = SchemaTestCase + { _scDescription :: Text + , _scData :: Value + , _scValid :: Bool + } deriving Generic + +instance FromJSON SchemaTest where + parseJSON = withObject "SchemaTest" $ \o -> SchemaTest + <$> o .: "description" + <*> o .: "schema" + <*> o .: "tests" -- Perhaps "cases" would have been a more descriptive key. + +instance FromJSON SchemaTestCase where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = fmap toLower . drop 3 } + +readSchemaTests :: String -> [String] -> IO [SchemaTest] +readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles + where + -- Each file contains an array of SchemaTests, not just one. + fileToCases :: String -> IO [SchemaTest] + fileToCases name = do + let fullPath = dir name + jsonBS <- LBS.readFile fullPath + case eitherDecode jsonBS of + Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e + Right schemaTests -> pure $ prependFileName name <$> schemaTests + + prependFileName :: String -> SchemaTest -> SchemaTest + prependFileName fileName s = s + { _stDescription = T.pack fileName <> ": " <> _stDescription s + } + + concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] + concatMapM f xs = liftM concat (mapM f xs) + +toTest :: SchemaTest -> TestTree +toTest st = + HU.testCase (T.unpack (_stDescription st)) $ do + forM_ (_stCases st) $ \sc -> do + g <- assertRight =<< D4.referencesViaHTTP (D4.SchemaWithURI (_stSchema st) Nothing) + validate <- assertRight . D4.checkSchema g $ D4.SchemaWithURI (_stSchema st) Nothing + let res = validate (_scData sc) + if _scValid sc + then assertValid sc res + else assertInvalid sc res + +assertValid :: SchemaTestCase -> [D4.Invalid] -> HU.Assertion +assertValid _ [] = pure () +assertValid sc errs = + HU.assertFailure $ unlines + [ " Failed to validate data" + , " Description: " <> T.unpack (_scDescription sc) + , " Data: " <> show (_scData sc) + , " Validation failures: " <> show errs + ] + +assertInvalid :: SchemaTestCase -> [D4.Invalid] -> HU.Assertion +assertInvalid sc [] = + HU.assertFailure $ unlines + [ " Validated invalid data" + , " Description: " <> T.unpack (_scDescription sc) + , " Data: " <> show (_scData sc) + ] +assertInvalid _ _ = pure () + +assertRight :: (Show a) => Either a b -> IO b +assertRight (Left e) = HU.assertFailure (show e) >> fail "assertRight failed" +assertRight (Right b) = pure b diff --git a/tests/Local.hs b/tests/Local.hs deleted file mode 100644 --- a/tests/Local.hs +++ /dev/null @@ -1,76 +0,0 @@ - -module Main where - -import Control.Applicative -import Control.Monad (unless) -import Data.Aeson -import qualified Data.Aeson.Pointer as P -import Data.List (isSuffixOf) -import Data.Monoid -import System.Directory (getDirectoryContents) -import Test.Tasty (TestTree, defaultMain, testGroup) -import qualified Test.Tasty.HUnit as HU -import Test.Tasty.QuickCheck (testProperty) - -import Data.JsonSchema.Draft4 (Failure(..), Schema(..), - SchemaCache(..), SchemaContext(..), - emptySchema, runValidate) -import qualified Data.Validator.Draft4 as VA -import Shared (isLocal, readSchemaTests, toTest) - -dir :: String -dir = "JSON-Schema-Test-Suite/tests/draft4" - -main :: IO () -main = do - filenames <- filter isLocal . filter (".json" `isSuffixOf`) <$> getDirectoryContents dir - ts <- readSchemaTests dir filenames - defaultMain . testGroup "Tests not requiring an HTTP server" $ - testProperty "Invert schemas through JSON without change" invertSchema - : testGroup "Make paths to invalid data correctly" correctPaths - : fmap toTest ts - -invertSchema :: Schema -> Bool -invertSchema a = Just a == decode (encode a) - -correctPaths :: [TestTree] -correctPaths = - [ HU.testCase "Items object" itemsObject - , HU.testCase "Items array" itemsArray - ] - -itemsObject :: IO () -itemsObject = HU.assertEqual "Path to invalid data" - (P.Pointer [P.Token "0"]) - (_failureOffendingData failure) - where - [failure] = runValidate (SchemaCache schema mempty) sc (toJSON [[True, True]]) - - schema :: Schema - schema = emptySchema - { _schemaItems = Just (VA.ItemsObject (emptySchema { _schemaUniqueItems = Just True })) - } - - sc :: SchemaContext Schema - sc = SchemaContext - { _scURI = Nothing - , _scSchema = schema - } - -itemsArray :: IO () -itemsArray = HU.assertEqual "Path to invalid data" - (P.Pointer [P.Token "0"]) - (_failureOffendingData failure) - where - [failure] = runValidate (SchemaCache schema mempty) sc (toJSON [[True, True]]) - - schema :: Schema - schema = emptySchema - { _schemaItems = Just (VA.ItemsArray [emptySchema { _schemaUniqueItems = Just True }]) - } - - sc :: SchemaContext Schema - sc = SchemaContext - { _scURI = Nothing - , _scSchema = schema - } diff --git a/tests/Remote.hs b/tests/Remote.hs deleted file mode 100644 --- a/tests/Remote.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Main where - -import Control.Applicative -import Control.Concurrent.Async (withAsync) -import Data.List (isSuffixOf) -import Network.Wai.Application.Static (defaultFileServerSettings, - staticApp) -import Network.Wai.Handler.Warp (run) -import System.Directory (getDirectoryContents) -import Test.Tasty (defaultMain, testGroup) - -import Shared (isLocal, readSchemaTests, - toTest) - -dir :: String -dir = "JSON-Schema-Test-Suite/tests/draft4" - -main :: IO () -main = withAsync serve $ \_ -> do - filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`) - <$> getDirectoryContents dir - ts <- readSchemaTests dir filenames - defaultMain . testGroup "Tests that run an HTTP server" $ toTest <$> ts - -serve :: IO () -serve = run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes" diff --git a/tests/Shared.hs b/tests/Shared.hs deleted file mode 100644 --- a/tests/Shared.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Shared where - -import Control.Applicative -import Control.Monad -import Data.Aeson -import Data.Aeson.TH -import qualified Data.ByteString.Lazy as LBS -import Data.Char (toLower) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import System.FilePath (()) -import Test.Tasty (TestTree) -import qualified Test.Tasty.HUnit as HU - -import qualified Data.JsonSchema.Draft4 as D4 - -isLocal :: String -> Bool -isLocal file = (file /= "definitions.json") - && (file /= "ref.json") - && (file /= "refRemote.json") - -data SchemaTest = SchemaTest - { _stDescription :: Text - , _stSchema :: D4.Schema - , _stCases :: [SchemaTestCase] - } - -data SchemaTestCase = SchemaTestCase - { _scDescription :: Text - , _scData :: Value - , _scValid :: Bool - } deriving Generic - -instance FromJSON SchemaTest where - parseJSON = withObject "SchemaTest" $ \o -> SchemaTest - <$> o .: "description" - <*> o .: "schema" - <*> o .: "tests" -- Perhaps "cases" would have been a more descriptive key. - -instance FromJSON SchemaTestCase where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = fmap toLower . drop 3 } - -readSchemaTests :: String -> [String] -> IO [SchemaTest] -readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles - where - -- Each file contains an array of SchemaTests, not just one. - fileToCases :: String -> IO [SchemaTest] - fileToCases name = do - let fullPath = dir name - jsonBS <- LBS.readFile fullPath - case eitherDecode jsonBS of - Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e - Right schemaTests -> pure $ prependFileName name <$> schemaTests - - prependFileName :: String -> SchemaTest -> SchemaTest - prependFileName fileName s = s - { _stDescription = T.pack fileName <> ": " <> _stDescription s - } - - concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] - concatMapM f xs = liftM concat (mapM f xs) - -toTest :: SchemaTest -> TestTree -toTest st = - HU.testCase (T.unpack (_stDescription st)) $ do - forM_ (_stCases st) $ \sc -> do - g <- assertRight =<< D4.fetchReferencedSchemas mempty (D4.SchemaContext Nothing (_stSchema st)) - validate <- assertRight . D4.checkSchema g $ D4.SchemaContext Nothing (_stSchema st) - let res = validate (_scData sc) - if _scValid sc - then assertValid sc res - else assertInvalid sc res - -assertValid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion -assertValid _ [] = pure () -assertValid sc errs = - HU.assertFailure $ unlines - [ " Failed to validate data" - , " Description: " <> T.unpack (_scDescription sc) - , " Data: " <> show (_scData sc) - , " Validation failures: " <> show errs - ] - -assertInvalid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion -assertInvalid sc [] = - HU.assertFailure $ unlines - [ " Validated invalid data" - , " Description: " <> T.unpack (_scDescription sc) - , " Data: " <> show (_scData sc) - ] -assertInvalid _ _ = pure () - -assertRight :: (Show a) => Either a b -> IO b -assertRight (Left e) = HU.assertFailure (show e) >> fail "assertRight failed" -assertRight (Right b) = pure b