diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,17 @@ ![hjsonschema logo](./logo.jpg) -A Haskell implementation of the current [JSON Schema](http://json-schema.org/) specification (Draft 4). +A Haskell implementation of the most commonly used [JSON Schema](http://json-schema.org/) specification ([Draft 4](https://github.com/json-schema-org/json-schema-spec/wiki/Specification-Links#draft-4)). [Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema) -Requires [pcre](http://www.pcre.org/) (`pkgs.pcre` in Nixpkgs). +# Notes -NOTE: Schemas with circular references can cause infinite loops. hjsonschema does loop detection but it may not be solid yet -- please open an issue if you find a situation where it fails. ++ As of 2017 [json-schema-org](https://github.com/json-schema-org/json-schema-spec) has begun releasing new drafts of the standard. Once this work stabilizes `hjsonschema` will add coverage for the latest draft. ++ Requires [pcre](http://www.pcre.org/) (`pkgs.pcre` in Nixpkgs). + ++ Schemas with circular references can cause infinite loops. hjsonschema does loop detection but it may not be solid yet -- please open an issue if you find a situation where it fails. + # Example See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Simple.hs). @@ -46,7 +50,7 @@ + Currently doesn't support the optional `"format"` validators. -## Notes +## Vendoring + `JSON-Schema-Test-Suite` is vendored from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite). diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -1,3 +1,17 @@ +# 1.3.0.0 + ++ Rewrite failure messages. + +We used to return a list of every failed validator, no matter how far it was buried within subschemas of the original schema. + +Now we return a tree of failure messages, so that if the first schema had only three validators, then no more than three top level failures will be returned. + ++ Move the code to parse each validator from JSON from `Data.Validator.Draft4` into the validators' modules themselves. + ++ Switch from Prelude to Protolude. + ++ Switch `Data.JsonSchema.Fetch` from lazy to strict bytestrings. + # 1.2.0.2 + Bump hspec. @@ -8,8 +22,7 @@ # 1.2.0.0 -+ Return `AdditionalPropertiesObject` error correctly (was mistakenly -returning `AdditionalItemsObject` instead. ++ Return `AdditionalPropertiesObject` error correctly (was mistakenly returning `AdditionalItemsObject` instead. + Don't silence errors resulting from subschemas of "anyOf" or "oneOf". # 1.1.0.1 @@ -18,33 +31,23 @@ # 1.1.0.0 -+ Rename `schemaForSchemas` to `metaSchema` and `schemaForSchemasBytes` to -`metaSchemaBytes`. ++ Rename `schemaForSchemas` to `metaSchema` and `schemaForSchemasBytes` to `metaSchemaBytes`. # 1.0.0.0 ## Bug fixes: -+ Fix JSON Pointer bug. Pointers were being built in reverse order and so were -totally invalid. -+ Use `.:!` instead of `.:?` to parse the draft 4 schema. The only way to omit -optional fields in JSON Schema Draft 4 is to omit them entirely, `"null"` -can't be used for this. ++ Fix JSON Pointer bug. Pointers were being built in reverse order and so were totally invalid. ++ Use `.:!` instead of `.:?` to parse the draft 4 schema. The only way to omit optional fields in JSON Schema Draft 4 is to omit them entirely, `"null"` can't be used for this. ## API Changes: + Add referenced schema loop detection. + Add a new `referencesValidity` function. -+ `checkSchema` now checks referenced schema's validity in addition to the -starting schema's validity. This change bubbles up to the one-step validation -functions as well. -+ Switch most of the fetching code to use `URISchemaMap` instead of -`ReferencedSchemas`. It didn't need to know about the more complicated data -type. -+ Rething failure related names. Change `Invalid` to `Failure`, add a new -`Invalid` type alias which is only used for final results. -+ Failures now include the failing part of the data as well as a JSON Pointer to -it, so you don't have to worry about resolving the pointer. ++ `checkSchema` now checks referenced schema's validity in addition to the starting schema's validity. This change bubbles up to the one-step validation functions as well. ++ Switch most of the fetching code to use `URISchemaMap` instead of `ReferencedSchemas`. It didn't need to know about the more complicated data type. ++ Rething failure related names. Change `Invalid` to `Failure`, add a new `Invalid` type alias which is only used for final results. ++ Failures now include the failing part of the data as well as a JSON Pointer to it, so you don't have to worry about resolving the pointer. ## Fundamental Changes: @@ -73,8 +76,7 @@ + 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. ++ 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. @@ -90,11 +92,8 @@ + Improve scope updating and resolving. + Rename RawSchema's _rsObject field to _rsData. -+ Make RawSchema's _rsURI field a Maybe. This way schemas without a starting -URI can say so explicitly with Nothing instead of with "". -+ Rename Graph to SchemaGraph. Declare it with data instead of type. Give it a -field referencing the starting schema. This field is used to find the curent -schema if no URI is in scope and a self-referencing $ref is found (e.g. "#"). ++ Make RawSchema's _rsURI field a Maybe. This way schemas without a starting URI can say so explicitly with Nothing instead of with "". ++ Rename Graph to SchemaGraph. Declare it with data instead of type. Give it a field referencing the starting schema. This field is used to find the curent schema if no URI is in scope and a self-referencing $ref is found (e.g. "#"). + Change the order of the last two arguments to fetchReferencedSchemas. # 0.7.1 @@ -105,13 +104,10 @@ Change error type from Text to ValidationFailure. -Revert the 0.6 changes to validate. Also switch from Vector -to list. Validate is now: +Revert the 0.6 changes to validate. Also switch from Vector to list. Validate is now: Schema err -> Value -> [ValidationFailure err] -Add fetchReferencedSchemas', which lets the user provide their -own MonadIO function to be used when fetching schemas. This lets -them do things like only fetch schemas from particular domains. +Add fetchReferencedSchemas', which lets the user provide their own MonadIO function to be used when fetching schemas. This lets them do things like only fetch schemas from particular domains. # 0.6 @@ -131,8 +127,7 @@ # 0.5.2 -+ Add convenience function for validating and compiling draft 4 schemas -simultaneously. ++ Add convenience function for validating and compiling draft 4 schemas simultaneously. # 0.5.1 diff --git a/examples/AlternateSchema.hs b/examples/AlternateSchema.hs --- a/examples/AlternateSchema.hs +++ b/examples/AlternateSchema.hs @@ -5,35 +5,29 @@ -- to copy this module instead of the 'Data.JsonSchema.Draft4'. While it's -- less convenient to write schemas in Haskell without a record type, you -- can get the implementation finished with far fewer lines of code. --- --- Note that this module imports the the failure sum type and failure related --- helper functions from the library. If you're implementing a custom schema --- with different error types from JSON Schema Draft 4 you'll have to make --- your own. module AlternateSchema where -import Data.Aeson (FromJSON(..), Value(..), - decode) -import qualified Data.Aeson as AE -import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) -import Data.Monoid -import Data.Profunctor (Profunctor (..)) -import Data.Text (Text) +import Protolude -import Data.JsonSchema.Draft4 (metaSchemaBytes) -import Data.JsonSchema.Draft4.Failure -import Data.JsonSchema.Fetch (ReferencedSchemas(..), - SchemaWithURI(..)) -import qualified Data.JsonSchema.Fetch as FE -import Data.JsonSchema.Types (Schema(..), Spec(..)) -import qualified Data.JsonSchema.Types as JT -import qualified Data.Validator.Draft4 as D4 -import qualified Data.Validator.Draft4.Any as AN -import Data.Validator.Reference (updateResolutionScope) +import Data.Aeson (FromJSON(..), Value(..), + decode) +import qualified Data.Aeson as AE +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import Data.Profunctor (Profunctor (..)) +import Data.JsonSchema.Draft4 (ValidatorFailure(..), + metaSchemaBytes) +import Data.JsonSchema.Fetch (ReferencedSchemas(..), + SchemaWithURI(..)) +import qualified Data.JsonSchema.Fetch as FE +import Data.JsonSchema.Types (Schema(..), Spec(..)) +import qualified Data.JsonSchema.Types as JT +import qualified Data.Validator.Draft4 as D4 +import Data.Validator.Reference (updateResolutionScope) + -------------------------------------------------- -- * Basic fetching tools -------------------------------------------------- @@ -44,12 +38,13 @@ referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo draft4FetchInfo :: FE.FetchInfo Schema -draft4FetchInfo = FE.FetchInfo embedded (get "id") (get "$ref") +draft4FetchInfo = FE.FetchInfo embedded (lookup "id") (lookup "$ref") where - get :: Text -> Schema -> Maybe Text - get k (Schema s) = case HM.lookup k s of - Just (String t) -> Just t - _ -> Nothing + lookup :: Text -> Schema -> Maybe Text + lookup k (Schema s) = + case HM.lookup k s of + Just (String t) -> Just t + _ -> Nothing embedded :: Schema -> ([Schema], [Schema]) embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s @@ -63,26 +58,26 @@ -> Maybe Text -> Schema -> Value - -> [Failure] -validate rs = continueValidating rs (AN.VisitedSchemas [(Nothing, Nothing)]) + -> [ValidatorFailure] +validate rs = continueValidating rs (D4.VisitedSchemas [(Nothing, Nothing)]) -- A schema for schemas themselves, using @src/draft4.json@ which is loaded -- at compile time. metaSchema :: Schema metaSchema = - fromMaybe (error "Schema decode failed (this should never happen)") + fromMaybe (panic "Schema decode failed (this should never happen)") . decode . LBS.fromStrict $ metaSchemaBytes -checkSchema :: Schema -> [Failure] +checkSchema :: Schema -> [ValidatorFailure] checkSchema = validate referenced Nothing metaSchema . Object . _unSchema where referenced :: ReferencedSchemas Schema referenced = ReferencedSchemas metaSchema (HM.singleton "http://json-schema.org/draft-04/schema" - metaSchema) + metaSchema) -------------------------------------------------- -- * Spec @@ -90,11 +85,11 @@ continueValidating :: ReferencedSchemas Schema - -> AN.VisitedSchemas + -> D4.VisitedSchemas -> Maybe Text -> Schema -> Value - -> [Failure] + -> [ValidatorFailure] continueValidating referenced visited mURI sc = JT.validate (d4Spec referenced visited newScope) sc where @@ -108,39 +103,52 @@ d4Spec :: ReferencedSchemas Schema - -> AN.VisitedSchemas + -> D4.VisitedSchemas -> Maybe Text - -> Spec Schema ValidatorChain + -> Spec Schema ValidatorFailure + -- ^ Here we reuses 'ValidatorFailure' from + -- 'Data.JsonSchema.Draft4.Failure'. If your validators have different + -- failure possibilities you'll need to create your own validator + -- failure type. d4Spec referenced visited scope = Spec - [ dimap f (const MultipleOf) D4.multipleOf - , dimap f maxE D4.maximumVal - , dimap f minE D4.minimumVal + [ dimap f FailureMultipleOf D4.multipleOfValidator + , dimap f FailureMaximum D4.maximumValidator + , dimap f FailureMinimum D4.minimumValidator - , dimap f (const MaxLength) D4.maxLength - , dimap f (const MinLength) D4.minLength - , dimap f (const PatternValidator) D4.patternVal + , dimap f FailureMaxLength D4.maxLengthValidator + , dimap f FailureMinLength D4.minLengthValidator + , dimap f FailurePattern D4.patternValidator - , dimap f (const MaxItems) D4.maxItems - , dimap f (const MinItems) D4.minItems - , dimap f (const UniqueItems) D4.uniqueItems - , dimap f itemsE (D4.items descend) + , dimap f FailureMaxItems D4.maxItemsValidator + , dimap f FailureMinItems D4.minItemsValidator + , dimap f FailureUniqueItems D4.uniqueItemsValidator + , dimap + (fromMaybe D4.emptyItems . f) + (\err -> case err of + D4.IRInvalidItems e -> FailureItems e + D4.IRInvalidAdditional e -> FailureAdditionalItems e) + (D4.itemsRelatedValidator descend) - , dimap f (const MaxProperties) D4.maxProperties - , dimap f (const MinProperties) D4.minProperties - , dimap f (const Required) D4.required - , dimap f depsE (D4.dependencies descend) - , dimap f propE (D4.properties descend) - , dimap f patPropE (D4.patternProperties descend) - , dimap f addPropE (D4.additionalProperties descend) + , dimap f FailureMaxProperties D4.maxPropertiesValidator + , dimap f FailureMinProperties D4.minPropertiesValidator + , dimap f FailureRequired D4.requiredValidator + , dimap f FailureDependencies (D4.dependenciesValidator descend) + , dimap + (fromMaybe D4.emptyProperties . f) + FailurePropertiesRelated + (D4.propertiesRelatedValidator descend) - , dimap f refE (D4.ref visited scope (FE.getReference referenced) refVal) - , dimap f (const Enum) D4.enumVal - , dimap f (const TypeValidator) D4.typeVal - , dimap f AllOf (D4.allOf lateral) - , dimap f AnyOf (D4.anyOf lateral) - , dimap f oneOfE (D4.oneOf lateral) - , dimap f (const NotValidator) (D4.notVal lateral) + , dimap + f + FailureRef + (D4.refValidator visited scope (FE.getReference referenced) getRef) + , dimap f FailureEnum D4.enumValidator + , dimap f FailureType D4.typeValidator + , dimap f FailureAllOf (D4.allOfValidator lateral) + , dimap f FailureAnyOf (D4.anyOfValidator lateral) + , dimap f FailureOneOf (D4.oneOfValidator lateral) + , dimap f FailureNot (D4.notValidator lateral) ] where f :: FromJSON a => Schema -> Maybe a @@ -148,13 +156,18 @@ AE.Error _ -> Nothing AE.Success b -> Just b - -- 'Maybe Text' is the URI the refernced schema is fetch from, + -- 'Maybe Text' is the URI the referenced schema is fetched from, -- this probably needs a 'newtype' wrapper. - refVal :: AN.VisitedSchemas -> Maybe Text -> Schema -> Value -> [Failure] - refVal = continueValidating referenced + getRef + :: D4.VisitedSchemas + -> Maybe Text + -> Schema + -> Value + -> [ValidatorFailure] + getRef = continueValidating referenced - descend :: Schema -> Value -> [Failure] + descend :: Schema -> Value -> [ValidatorFailure] descend = continueValidating referenced mempty scope - lateral :: Schema -> Value -> [Failure] + lateral :: Schema -> Value -> [ValidatorFailure] lateral = continueValidating referenced visited scope diff --git a/examples/Full.hs b/examples/Full.hs deleted file mode 100644 --- a/examples/Full.hs +++ /dev/null @@ -1,40 +0,0 @@ --- | Two differences from @examples/Simple.hs@: --- --- * This shows how to write the starting schema in Haskell instead --- of parsing it from JSON. --- --- * Validation is done in two steps using 'D4.referencesViaFilesystem' and --- 'D4.checkSchema' instead of 'D4.fetchFilesystemAndValidate'. This means --- that the actual validation involves no IO. - -module Full where - -import Data.Aeson (Value (..), toJSON) - -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/start.json" - } - -badData :: Value -badData = toJSON (["foo", "foo"] :: [String]) - -example :: IO () -example = do - res <- D4.referencesViaFilesystem schemaContext - let references = case res of - Left _ -> error "Couldn't fetch referenced schemas." - Right a -> a - 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.Failure (D4.Ref D4.UniqueItems) _ _ _] -> return () -- Success - _ -> error "We got a different failure than expected." diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -1,10 +1,8 @@ --- | Demonstrate 'D4.fetchFilesystemAndValidate'. --- --- To fetch schemas using HTTP instead of from the filesystem use --- 'D4.fetchHTTPAndValidate'. module Simple where +import Protolude + import Data.Aeson (Value(..), decode, toJSON) import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE @@ -13,25 +11,28 @@ import qualified Data.JsonSchema.Draft4 as D4 badData :: Value -badData = toJSON (["foo", "foo"] :: [String]) +badData = toJSON [True, True] example :: IO () example = do - - -- Get the starting schema. - bts <- LBS.readFile "./examples/json/start.json" - let schema = fromMaybe (error "Invalid schema JSON.") (decode bts) - schemaWithURI = D4.SchemaWithURI schema (Just "./examples/json/start.json") + bts <- LBS.readFile "./examples/json/unique.json" + let schema = fromMaybe (panic "Invalid schema JSON.") (decode bts) + schemaWithURI = D4.SchemaWithURI + schema + Nothing -- This would be the URI of the schema + -- if it had one. It's used if the schema + -- has relative references to other + -- schemas. - -- Fetch any referenced schemas, check that our original schema itself - -- is valid, and validate the data. - res <- D4.fetchFilesystemAndValidate schemaWithURI badData + -- Fetch any referenced schemas over HTTP, check that our original schema + -- itself is valid, and validate the data. + res <- D4.fetchHTTPAndValidate schemaWithURI 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) -> + Right () -> panic "We validated bad data." + Left (D4.HVRequest _) -> panic ("Error fetching a referenced schema" + <> " (either during IO or parsing).") + Left (D4.HVSchema _) -> panic "Our 'schema' itself was invalid." + Left (D4.HVData (D4.Invalid _ _ failures)) -> case NE.toList failures of - [D4.Failure (D4.Ref D4.UniqueItems) _ _ _] -> return () -- Success. - _ -> error "Got more invalidation reasons than we expected." + [D4.FailureUniqueItems _] -> pure () -- Success. + _ -> panic "We got a different failure than expected." diff --git a/examples/TwoStep.hs b/examples/TwoStep.hs new file mode 100644 --- /dev/null +++ b/examples/TwoStep.hs @@ -0,0 +1,49 @@ +-- | Differences from @examples/Simple.hs@: +-- +-- * We demonstrate how to do the validation step without IO by first +-- getting the references with 'D4.referencesViaFilesystem'. +-- +-- * This shows how to write the starting schema in Haskell instead +-- of parsing it from JSON. +-- +-- * This schema references other schemas. Previously we used +-- 'fetchHTTPAndValidate' which fetched references over HTTP (though it +-- didn't matter because the last schema didn't actually have any). +-- This time we need to get them from the filesystem. + +module TwoStep where + +import Protolude + +import Data.Aeson (Value (..), toJSON) +import qualified Data.List.NonEmpty as NE + +import qualified Data.JsonSchema.Draft4 as D4 +import qualified Data.Validator.Draft4 as VAL + +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/start.json" + } + +badData :: Value +badData = toJSON [True, True] + +example :: IO () +example = do + res <- D4.referencesViaFilesystem schemaContext + let references = case res of + Left _ -> panic "Couldn't fetch referenced schemas." + Right a -> a + validate = case D4.checkSchema references schemaContext of + Left _ -> panic "Not a valid schema." + Right f -> f + case validate badData of + [] -> panic "We validated bad data." + [D4.FailureRef (VAL.RefInvalid _ _ (D4.FailureUniqueItems _ NE.:|[])) ] -> + pure () -- Success + _ -> panic "We got a different failure than expected." diff --git a/hjsonschema.cabal b/hjsonschema.cabal --- a/hjsonschema.cabal +++ b/hjsonschema.cabal @@ -1,5 +1,5 @@ name: hjsonschema -version: 1.2.0.2 +version: 1.3.0.0 synopsis: JSON Schema library homepage: https://github.com/seagreen/hjsonschema license: MIT @@ -26,15 +26,15 @@ src default-language: Haskell2010 default-extensions: + DeriveFunctor + DeriveGeneric + GeneralizedNewtypeDeriving NoImplicitPrelude OverloadedStrings ScopedTypeVariables + TupleSections if impl(ghc >= 8) default-extensions: StrictData - other-extensions: - DeriveFunctor - GeneralizedNewtypeDeriving - TemplateHaskell ghc-options: -Wall exposed-modules: @@ -50,7 +50,6 @@ , Data.Validator.Draft4.Number , Data.Validator.Draft4.Object , Data.Validator.Draft4.String - , Data.Validator.Failure , Data.Validator.Reference , Data.Validator.Types , Data.Validator.Utils @@ -60,17 +59,19 @@ build-depends: base >= 4.7 && < 4.10 -- 0.11 is for `.:!`: - , aeson >= 0.11 && < 1.1 + , aeson >= 0.11 && < 1.2 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 , file-embed >= 0.0.8 && < 0.1 , filepath >= 1.3 && < 1.5 - , hjsonpointer >= 0.3 && < 1.1 + , hashable >= 1.2 && < 1.3 + , hjsonpointer >= 1.1 && < 1.2 -- 0.4.30 is for parseUrlThrow: , http-client >= 0.4.30 && < 0.6 , http-types >= 0.8 && < 0.10 , pcre-heavy >= 1.0 && < 1.1 , profunctors >= 5.0 && < 5.3 + , protolude >= 0.1.10 && < 1.2 , QuickCheck >= 2.8 && < 2.10 , scientific >= 0.3 && < 0.4 , semigroups >= 0.18 && < 0.19 @@ -89,6 +90,8 @@ -Wall -fno-warn-orphans default-extensions: + DeriveGeneric + NoImplicitPrelude OverloadedStrings ScopedTypeVariables other-modules: @@ -98,8 +101,8 @@ , Shared -- from ./examples: , AlternateSchema - , Full , Simple + , TwoStep build-depends: base , aeson @@ -108,6 +111,7 @@ , hjsonpointer , hjsonschema , profunctors + , protolude , semigroups , text , QuickCheck @@ -129,6 +133,8 @@ -Wall -fno-warn-orphans default-extensions: + DeriveGeneric + NoImplicitPrelude OverloadedStrings ScopedTypeVariables other-modules: @@ -144,6 +150,7 @@ , hjsonpointer , hjsonschema , profunctors + , protolude , semigroups , text , unordered-containers 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 @@ -10,7 +10,7 @@ , fetchHTTPAndValidate , HTTPValidationFailure(..) , FE.HTTPFailure(..) - , InvalidSchema + , SchemaInvalid(..) -- * One-step validation (getting references from the filesystem) , fetchFilesystemAndValidate @@ -18,13 +18,12 @@ , FE.FilesystemFailure(..) -- * Validation failure - , Invalid - , Failure - , FR.Fail(..) - , ValidatorChain(..) + , Invalid(..) + , ValidatorFailure(..) -- * Fetching tools , ReferencedSchemas(..) + , FE.URISchemaMap(..) , referencesViaHTTP , referencesViaFilesystem @@ -38,9 +37,8 @@ ) where import Import -import Prelude -import Control.Arrow (first, left) +import Control.Arrow (left) import qualified Data.ByteString as BS import Data.FileEmbed (embedFile, makeRelativeToProject) @@ -48,25 +46,24 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) -import Data.JsonSchema.Draft4.Failure (Failure, Invalid, - InvalidSchema, - ValidatorChain(..)) +import Data.JsonSchema.Draft4.Failure (Invalid(..), + SchemaInvalid(..), + ValidatorFailure(..)) import Data.JsonSchema.Draft4.Schema (Schema) import qualified Data.JsonSchema.Draft4.Schema as SC import qualified Data.JsonSchema.Draft4.Spec as Spec import Data.JsonSchema.Fetch (ReferencedSchemas(..), SchemaWithURI(..)) import qualified Data.JsonSchema.Fetch as FE -import qualified Data.Validator.Failure as FR data HTTPValidationFailure = HVRequest FE.HTTPFailure - | HVSchema InvalidSchema + | HVSchema SchemaInvalid | HVData Invalid deriving Show -- | Fetch recursively referenced schemas over HTTP, check that both the --- original and referenced schemas are valid, and then validate data. +-- original and referenced schemas are valid, then validate then data. fetchHTTPAndValidate :: SchemaWithURI Schema -> Value @@ -76,23 +73,27 @@ pure (g =<< f =<< left HVRequest res) where f :: FE.URISchemaMap Schema - -> Either HTTPValidationFailure (Value -> [Failure]) + -> Either HTTPValidationFailure (Value -> [ValidatorFailure]) f references = left HVSchema (checkSchema references sw) - g :: (Value -> [Failure]) -> Either HTTPValidationFailure () - g validate = case NE.nonEmpty (validate v) of - Nothing -> Right () - Just failures -> Left (HVData failures) + g :: (Value -> [ValidatorFailure]) -> Either HTTPValidationFailure () + g val = case NE.nonEmpty (val v) of + Nothing -> Right () + Just failures -> Left (HVData Invalid + { _invalidSchema = _swSchema sw + , _invalidInstance = v + , _invalidFailures = failures + }) data FilesystemValidationFailure = FVRead FE.FilesystemFailure - | FVSchema InvalidSchema + | FVSchema SchemaInvalid | FVData Invalid deriving (Show, Eq) --- | Fetch recursively referenced schemas from the filesystem, check that --- both the original and referenced schemas are valid, and then --- validate data. +-- | Fetch recursively referenced schemas from the filesystem, check +-- that both the original and referenced schemas are valid, then validate +-- the data. fetchFilesystemAndValidate :: SchemaWithURI Schema -> Value @@ -102,13 +103,17 @@ pure (g =<< f =<< left FVRead res) where f :: FE.URISchemaMap Schema - -> Either FilesystemValidationFailure (Value -> [Failure]) + -> Either FilesystemValidationFailure (Value -> [ValidatorFailure]) f references = left FVSchema (checkSchema references sw) - g :: (Value -> [Failure]) -> Either FilesystemValidationFailure () - g validate = case NE.nonEmpty (validate v) of - Nothing -> Right () - Just invalid -> Left (FVData invalid) + g :: (Value -> [ValidatorFailure]) -> Either FilesystemValidationFailure () + g val = case NE.nonEmpty (val v) of + Nothing -> Right () + Just invalid -> Left (FVData Invalid + { _invalidSchema = _swSchema sw + , _invalidInstance = v + , _invalidFailures = invalid + }) -- | An instance of 'Data.JsonSchema.Fetch.FetchInfo' specialized for -- JSON Schema Draft 4. @@ -128,27 +133,31 @@ -> IO (Either FE.FilesystemFailure (FE.URISchemaMap Schema)) referencesViaFilesystem = FE.referencesViaFilesystem' draft4FetchInfo --- | A helper function. --- --- Checks if a schema and a set of referenced schemas are valid. +-- | Checks if a schema and a set of referenced schemas are valid. -- -- Return a function to validate data. checkSchema :: FE.URISchemaMap Schema -> SchemaWithURI Schema - -> Either InvalidSchema (Value -> [Failure]) + -> Either SchemaInvalid (Value -> [ValidatorFailure]) checkSchema sm sw = case NE.nonEmpty failures of - Nothing -> Right (Spec.validate (ReferencedSchemas (_swSchema sw) sm) sw) - Just fs -> Left fs + Just fs -> Left (SchemaInvalid fs) + Nothing -> Right (Spec.specValidate + (ReferencedSchemas (_swSchema sw) + (FE._unURISchemaMap sm)) + sw) where - failures :: [(Maybe Text, Failure)] - failures = ((\v -> (Nothing, v)) <$> schemaValidity (_swSchema sw)) - <> (first Just <$> referencesValidity sm) + failures :: [(Maybe Text, NonEmpty ValidatorFailure)] + failures = + let refFailures = first Just <$> referencesValidity sm + in case NE.nonEmpty (schemaValidity (_swSchema sw)) of + Nothing -> refFailures + Just errs -> (Nothing,errs) : refFailures metaSchema :: Schema metaSchema = - fromMaybe (error "Schema decode failed (this should never happen)") + fromMaybe (panic "Schema decode failed (this should never happen)") . decodeStrict $ metaSchemaBytes @@ -158,26 +167,29 @@ -- | Check that a schema itself is valid -- (if so the returned list will be empty). -schemaValidity :: Schema -> [Failure] +schemaValidity :: Schema -> [ValidatorFailure] schemaValidity = - Spec.validate referenced (SchemaWithURI metaSchema Nothing) . toJSON + Spec.specValidate referenced (SchemaWithURI metaSchema Nothing) . toJSON where referenced :: ReferencedSchemas Schema referenced = ReferencedSchemas metaSchema (HM.singleton "http://json-schema.org/draft-04/schema" - metaSchema) + metaSchema) -- | Check that a set of referenced schemas are valid -- (if so the returned list will be empty). referencesValidity :: FE.URISchemaMap Schema - -> [(Text, Failure)] - -- ^ The first value in the tuple is the URI of a referenced schema. -referencesValidity = HM.foldlWithKey' f mempty + -> [(Text, NonEmpty ValidatorFailure)] + -- ^ The first item of the tuple is the URI of a schema, the second + -- is that schema's validation errors. +referencesValidity = HM.foldlWithKey' f mempty . FE._unURISchemaMap where - f :: [(Text, Failure)] + f :: [(Text, NonEmpty ValidatorFailure)] -> Text -> Schema - -> [(Text, Failure)] - f acc k v = ((\a -> (k,a)) <$> schemaValidity v) <> acc + -> [(Text, NonEmpty ValidatorFailure)] + f acc k v = case NE.nonEmpty (schemaValidity v) of + Nothing -> acc + Just errs -> (k,errs) : acc 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,123 +1,59 @@ module Data.JsonSchema.Draft4.Failure where -import Prelude - -import Data.List.NonEmpty (NonEmpty) -import Data.Text (Text) - -import qualified Data.Validator.Draft4.Any as AN -import qualified Data.Validator.Draft4.Array as AR -import qualified Data.Validator.Draft4.Number as NU -import qualified Data.Validator.Draft4.Object as OB -import qualified Data.Validator.Failure as FR - --- | A description of why a schema (or one of its reference) is itself --- invalid. --- --- 'Nothing' indicates the starting schema. 'Just' indicates a referenced --- schema -- the contents of the 'Just' is the schema's URI. --- --- NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of defining --- this, but then we lose the guarantee that there's at least one key. -type InvalidSchema = NonEmpty (Maybe Text, Failure) +import Import -type Invalid = NonEmpty Failure +import Data.JsonSchema.Draft4.Schema (Schema) +import qualified Data.Validator.Draft4 as D4 -type Failure = FR.Fail ValidatorChain +-- | Used to report an entire instance being invalidated, as opposed +-- to the failure of a single validator. +data Invalid = Invalid + { _invalidSchema :: Schema + , _invalidInstance :: Value + , _invalidFailures :: NonEmpty ValidatorFailure + } deriving (Eq, Show) --- | Distinguish all the different possible causes of failure for --- Draft 4 validation. -data ValidatorChain - = MultipleOf - | Maximum - | ExclusiveMaximum - | Minimum - | ExclusiveMinimum +data ValidatorFailure + = FailureMultipleOf D4.MultipleOfInvalid + | FailureMaximum D4.MaximumInvalid + | FailureMinimum D4.MinimumInvalid - | MaxLength - | MinLength - | PatternValidator + | FailureMaxLength D4.MaxLengthInvalid + | FailureMinLength D4.MinLengthInvalid + | FailurePattern D4.PatternInvalid - | MaxItems - | MinItems - | UniqueItems - | Items ValidatorChain - | AdditionalItemsBool - | AdditionalItemsObject ValidatorChain + | FailureMaxItems D4.MaxItemsInvalid + | FailureMinItems D4.MinItemsInvalid + | FailureUniqueItems D4.UniqueItemsInvalid + | FailureItems (D4.ItemsInvalid ValidatorFailure) + | FailureAdditionalItems (D4.AdditionalItemsInvalid ValidatorFailure) - | MaxProperties - | MinProperties - | Required - | SchemaDependency ValidatorChain - | PropertyDependency - | Properties ValidatorChain - | PatternProperties ValidatorChain - | AdditionalPropertiesBool - | AdditionalPropertiesObject ValidatorChain + | FailureMaxProperties D4.MaxPropertiesInvalid + | FailureMinProperties D4.MinPropertiesInvalid + | FailureRequired () + | FailureDependencies (D4.DependenciesInvalid ValidatorFailure) + | FailurePropertiesRelated (D4.PropertiesRelatedInvalid ValidatorFailure) - | RefResolution - -- ^ Indicates a reference that failed to resolve. - -- - -- NOTE: The language agnostic test suite doesn't specify if this should - -- cause a validation error or should allow data to pass. We choose to - -- return a validation error. - -- - -- Also note that ideally we would enforce in the type system that any - -- failing references be dealt with before valididation. Then this could - -- be removed entirely. - | RefLoop - | Ref ValidatorChain - | Enum - | TypeValidator - | AllOf ValidatorChain - | AnyOf ValidatorChain - | OneOfTooManySuccesses - | OneOfNoSuccesses ValidatorChain - | NotValidator + | FailureRef (D4.RefInvalid ValidatorFailure) + | FailureEnum D4.EnumInvalid + | FailureType D4.TypeValidatorInvalid + | FailureAllOf (D4.AllOfInvalid ValidatorFailure) + | FailureAnyOf (D4.AnyOfInvalid ValidatorFailure) + | FailureOneOf (D4.OneOfInvalid ValidatorFailure) + | FailureNot D4.NotValidatorInvalid deriving (Eq, Show) -maxE :: NU.MaximumInvalid -> ValidatorChain -maxE NU.Maximum = Maximum -maxE NU.ExclusiveMaximum = ExclusiveMaximum - -minE :: NU.MinimumInvalid -> ValidatorChain -minE NU.Minimum = Minimum -minE NU.ExclusiveMinimum = ExclusiveMinimum - -itemsE :: AR.ItemsInvalid ValidatorChain -> ValidatorChain -itemsE (AR.Items err) = Items err -itemsE AR.AdditionalItemsBoolInvalid = AdditionalItemsBool -itemsE (AR.AdditionalItemsObjectInvalid err) = AdditionalItemsObject err - -depsE :: OB.DependencyInvalid ValidatorChain -> ValidatorChain -depsE (OB.SchemaDependencyInvalid err) = SchemaDependency err -depsE OB.PropertyDependencyInvalid = PropertyDependency - -propE :: OB.PropertiesInvalid ValidatorChain -> ValidatorChain -propE (OB.PropertiesInvalid err) = Properties err -propE (OB.PropPatternInvalid err) = PatternProperties err -propE (OB.PropAdditionalInvalid a) = - case a of - OB.APBoolInvalid -> AdditionalPropertiesBool - OB.APObjectInvalid err -> AdditionalPropertiesObject err - -patPropE :: OB.PatternPropertiesInvalid ValidatorChain -> ValidatorChain -patPropE (OB.PPInvalid err) = PatternProperties err -patPropE (OB.PPAdditionalPropertiesInvalid a) = - case a of - OB.APBoolInvalid -> AdditionalPropertiesBool - OB.APObjectInvalid err -> AdditionalPropertiesObject err - -addPropE :: OB.AdditionalPropertiesInvalid ValidatorChain -> ValidatorChain -addPropE OB.APBoolInvalid = AdditionalPropertiesBool -addPropE (OB.APObjectInvalid err) = AdditionalPropertiesObject err - -refE :: AN.RefInvalid ValidatorChain -> ValidatorChain -refE AN.RefResolution = RefResolution -refE AN.RefLoop = RefLoop -refE (AN.RefInvalid err) = Ref err - -oneOfE :: AN.OneOfInvalid ValidatorChain -> ValidatorChain -oneOfE AN.TooManySuccesses = OneOfTooManySuccesses -oneOfE (AN.NoSuccesses err) = OneOfNoSuccesses err +-- | A description of why a schema (or one of its reference) is itself +-- invalid. +-- +-- 'Nothing' indicates the starting schema. 'Just' indicates a referenced +-- schema. The contents of the 'Just' is the schema's URI. +-- +-- NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of +-- defining this, but then we lose the guarantee that there's at least +-- one key. +newtype SchemaInvalid + = SchemaInvalid { + _unSchemaInvalid :: NonEmpty (Maybe Text, NonEmpty ValidatorFailure) } + deriving (Eq, Show) diff --git a/src/Data/JsonSchema/Draft4/Schema.hs b/src/Data/JsonSchema/Draft4/Schema.hs --- a/src/Data/JsonSchema/Draft4/Schema.hs +++ b/src/Data/JsonSchema/Draft4/Schema.hs @@ -1,17 +1,16 @@ module Data.JsonSchema.Draft4.Schema where -import Import -import Prelude +import Import hiding (mapMaybe) -import qualified Data.HashMap.Strict as HM -import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (fromJust, isJust) +import qualified Data.HashMap.Strict as HM +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (fromJust, isJust) import Data.Scientific +import qualified Data.Set as Set +import qualified Data.Text as T -import qualified Data.Validator.Draft4.Any as AN -import qualified Data.Validator.Draft4.Array as AR -import qualified Data.Validator.Draft4.Object as OB +import qualified Data.Validator.Draft4 as D4 import Data.Validator.Utils data Schema = Schema @@ -26,6 +25,10 @@ -- contain schemas anywhere (not just in "definitions" or any -- of the other official keys) we save any leftover key/value -- pairs not covered by them here. + -- + -- TODO: This field is the source of most of the complication in this + -- module and needs to be removed. It should be doable, though it will + -- involve some modification to the fetching code. , _schemaMultipleOf :: Maybe Scientific , _schemaMaximum :: Maybe Scientific @@ -40,22 +43,22 @@ , _schemaMaxItems :: Maybe Int , _schemaMinItems :: Maybe Int , _schemaUniqueItems :: Maybe Bool - , _schemaItems :: Maybe (AR.Items Schema) + , _schemaItems :: Maybe (D4.Items Schema) -- Note that '_schemaAdditionalItems' is left out of 'runValidate' -- because its functionality is handled by '_schemaItems'. It always -- validates data unless 'Items' is present. - , _schemaAdditionalItems :: Maybe (AR.AdditionalItems Schema) + , _schemaAdditionalItems :: Maybe (D4.AdditionalItems Schema) , _schemaMaxProperties :: Maybe Int , _schemaMinProperties :: Maybe Int - , _schemaRequired :: Maybe OB.Required - , _schemaDependencies :: Maybe (HashMap Text (OB.Dependency Schema)) + , _schemaRequired :: Maybe (Set Text) + , _schemaDependencies :: Maybe (HashMap Text (D4.Dependency Schema)) , _schemaProperties :: Maybe (HashMap Text Schema) , _schemaPatternProperties :: Maybe (HashMap Text Schema) - , _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema) + , _schemaAdditionalProperties :: Maybe (D4.AdditionalProperties Schema) - , _schemaEnum :: Maybe AN.EnumVal - , _schemaType :: Maybe AN.TypeVal + , _schemaEnum :: Maybe (NonEmpty Value) + , _schemaType :: Maybe D4.TypeValidator , _schemaAllOf :: Maybe (NonEmpty Schema) , _schemaAnyOf :: Maybe (NonEmpty Schema) , _schemaOneOf :: Maybe (NonEmpty Schema) @@ -262,9 +265,9 @@ a <- maybeGen arbitraryText b <- maybeGen arbitraryText c <- maybeGen arbitraryText - -- NOTE: The next two fields are empty to generate cleaner schemas, - -- but note that this means we don't test e.g. the invertability - -- of these fields. + -- NOTE: The next two fields are empty to generate cleaner + -- schemas, but note that this means we don't test the + -- invertability of these fields. d <- pure Nothing -- _schemaDefinitions e <- pure mempty -- _otherPairs @@ -286,13 +289,14 @@ s <- maybeGen (getPositive <$> arbitrary) t <- maybeGen (getPositive <$> arbitrary) - u <- arbitrary + u <- maybeGen (Set.map T.pack <$> arbitrary) v <- maybeRecurse n arbitraryHashMap w <- maybeRecurse n arbitraryHashMap x <- maybeRecurse n arbitraryHashMap y <- maybeRecurse n arbitrary - z <- arbitrary + z <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty' + <$> arbitrary) a2 <- arbitrary b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) diff --git a/src/Data/JsonSchema/Draft4/Spec.hs b/src/Data/JsonSchema/Draft4/Spec.hs --- a/src/Data/JsonSchema/Draft4/Spec.hs +++ b/src/Data/JsonSchema/Draft4/Spec.hs @@ -2,10 +2,8 @@ module Data.JsonSchema.Draft4.Spec where import Import --- Hiding is for GHCs before 7.10: -import Prelude hiding (concat) -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe) import Data.Profunctor (Profunctor(..)) import Data.JsonSchema.Draft4.Failure @@ -15,33 +13,26 @@ import qualified Data.JsonSchema.Fetch as FE import Data.JsonSchema.Types (Spec(..)) import qualified Data.JsonSchema.Types as JT -import qualified Data.Validator.Draft4 as D4 -import qualified Data.Validator.Draft4.Any as AN +import Data.Validator.Draft4 import Data.Validator.Reference (updateResolutionScope) embedded :: Schema -> ([Schema], [Schema]) embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s --- | For internal use. --- --- A specialized version of 'const' that prevents overwriting --- useful information. -toss :: a -> () -> a -toss = const - -validate +specValidate :: ReferencedSchemas Schema -> SchemaWithURI Schema -> Value - -> [Failure] -validate rs = continueValidating rs (AN.VisitedSchemas [(Nothing, Nothing)]) + -> [ValidatorFailure] +specValidate rs = + continueValidating rs (VisitedSchemas [(Nothing, Nothing)]) continueValidating :: ReferencedSchemas Schema - -> AN.VisitedSchemas + -> VisitedSchemas -> SchemaWithURI Schema -> Value - -> [Failure] + -> [ValidatorFailure] continueValidating referenced visited sw = JT.validate (d4Spec referenced visited currentScope) (_swSchema sw) @@ -53,85 +44,85 @@ d4Spec :: ReferencedSchemas Schema - -> AN.VisitedSchemas + -> VisitedSchemas -> Maybe Text - -> Spec Schema ValidatorChain + -> Spec Schema ValidatorFailure d4Spec referenced visited scope = Spec - [ dimap - (fmap D4.MultipleOf . _schemaMultipleOf) - (toss MultipleOf) - D4.multipleOf + [ dimap (fmap MultipleOf . _schemaMultipleOf) FailureMultipleOf multipleOfValidator , dimap - (\s -> D4.MaximumContext (fromMaybe False (_schemaExclusiveMaximum s)) - <$> _schemaMaximum s) - maxE - D4.maximumVal + (\s -> Maximum (fromMaybe False (_schemaExclusiveMaximum s)) <$> _schemaMaximum s) + FailureMaximum + maximumValidator , dimap - (\s -> D4.MinimumContext (fromMaybe False (_schemaExclusiveMinimum s)) - <$> _schemaMinimum s) - minE - D4.minimumVal + (\s -> Minimum (fromMaybe False (_schemaExclusiveMinimum s)) <$> _schemaMinimum s) + FailureMinimum + minimumValidator - , dimap (fmap D4.MaxLength . _schemaMaxLength) (toss MaxLength) D4.maxLength - , dimap (fmap D4.MinLength . _schemaMinLength) (toss MinLength) D4.minLength - , dimap (fmap D4.PatternVal . _schemaPattern) (toss PatternValidator) D4.patternVal + , dimap (fmap MaxLength . _schemaMaxLength) FailureMaxLength maxLengthValidator + , dimap (fmap MinLength . _schemaMinLength) FailureMinLength minLengthValidator + , dimap (fmap PatternValidator . _schemaPattern) FailurePattern patternValidator - , dimap (fmap D4.MaxItems . _schemaMaxItems) (toss MaxItems) D4.maxItems - , dimap (fmap D4.MinItems . _schemaMinItems) (toss MinItems) D4.minItems - , dimap (fmap D4.UniqueItems . _schemaUniqueItems) (toss UniqueItems) D4.uniqueItems + , dimap (fmap MaxItems . _schemaMaxItems) FailureMaxItems maxItemsValidator + , dimap (fmap MinItems . _schemaMinItems) FailureMinItems minItemsValidator + , dimap (fmap UniqueItems . _schemaUniqueItems) FailureUniqueItems uniqueItemsValidator , dimap - (\s -> D4.ItemsContext (_schemaAdditionalItems s) <$> _schemaItems s) - itemsE - (D4.items descend) - , lmap (fmap D4.AdditionalItemsContext . _schemaAdditionalItems) D4.additionalItemsEmbedded - , lmap (fmap D4.Definitions . _schemaDefinitions) D4.definitionsEmbedded + (\s -> ItemsRelated + { _irItems = _schemaItems s + , _irAdditional = _schemaAdditionalItems s + }) + (\err -> case err of + IRInvalidItems e -> FailureItems e + IRInvalidAdditional e -> FailureAdditionalItems e) + (itemsRelatedValidator descend) + , lmap (fmap Definitions . _schemaDefinitions) definitionsEmbedded - , dimap (fmap D4.MaxProperties . _schemaMaxProperties) (toss MaxProperties) D4.maxProperties - , dimap (fmap D4.MinProperties . _schemaMinProperties) (toss MinProperties) D4.minProperties - , dimap (fmap D4.RequiredContext . _schemaRequired) (toss Required) D4.required - , dimap (fmap D4.DependenciesContext . _schemaDependencies) depsE (D4.dependencies descend) , dimap - (\s -> D4.PropertiesContext - (_schemaPatternProperties s) - (_schemaAdditionalProperties s) - <$> _schemaProperties s) - propE - (D4.properties descend) + (fmap MaxProperties . _schemaMaxProperties) + FailureMaxProperties + maxPropertiesValidator , dimap - (\s -> D4.PatternPropertiesContext - (isNothing (_schemaProperties s)) - (_schemaAdditionalProperties s) - <$> _schemaPatternProperties s) - patPropE - (D4.patternProperties descend) + (fmap MinProperties . _schemaMinProperties) + FailureMinProperties + minPropertiesValidator + , dimap (fmap Required . _schemaRequired) FailureRequired requiredValidator , dimap - (\s -> D4.AdditionalPropertiesContext - (isNothing (_schemaProperties s) - && isNothing (_schemaPatternProperties s)) - <$> _schemaAdditionalProperties s) - addPropE - (D4.additionalProperties descend) + (fmap DependenciesValidator . _schemaDependencies) + FailureDependencies + (dependenciesValidator descend) + , dimap + (\s -> PropertiesRelated + { _propProperties = _schemaProperties s + , _propPattern = _schemaPatternProperties s + , _propAdditional = _schemaAdditionalProperties s + }) + FailurePropertiesRelated + (propertiesRelatedValidator descend) , dimap - (\s -> D4.Ref <$> _schemaRef s) - refE - (D4.ref visited scope (FE.getReference referenced) refVal) - , dimap (fmap D4.EnumContext . _schemaEnum) (toss Enum) D4.enumVal - , dimap (fmap D4.TypeContext . _schemaType) (toss TypeValidator) D4.typeVal - , dimap (fmap D4.AllOf . _schemaAllOf) AllOf (D4.allOf lateral) - , dimap (fmap D4.AnyOf . _schemaAnyOf) AnyOf (D4.anyOf lateral) - , dimap (fmap D4.OneOf . _schemaOneOf) oneOfE (D4.oneOf lateral) - , dimap (fmap D4.NotVal . _schemaNot) (toss NotValidator) (D4.notVal lateral) + (\s -> Ref <$> _schemaRef s) + FailureRef + (refValidator visited scope (FE.getReference referenced) getRef) + , dimap (fmap EnumValidator . _schemaEnum) FailureEnum enumValidator + , dimap (fmap TypeContext . _schemaType) FailureType typeValidator + , dimap (fmap AllOf . _schemaAllOf) FailureAllOf (allOfValidator lateral) + , dimap (fmap AnyOf . _schemaAnyOf) FailureAnyOf (anyOfValidator lateral) + , dimap (fmap OneOf . _schemaOneOf) FailureOneOf (oneOfValidator lateral) + , dimap (fmap NotValidator . _schemaNot) FailureNot (notValidator lateral) ] where - refVal :: AN.VisitedSchemas -> Maybe Text -> Schema -> Value -> [Failure] - refVal newVisited newScope schema = + getRef + :: VisitedSchemas + -> Maybe Text + -> Schema + -> Value + -> [ValidatorFailure] + getRef newVisited newScope schema = continueValidating referenced newVisited (SchemaWithURI schema newScope) - descend :: Schema -> Value -> [Failure] + descend :: Schema -> Value -> [ValidatorFailure] descend schema = continueValidating referenced mempty (SchemaWithURI schema scope) - lateral :: Schema -> Value -> [Failure] + lateral :: Schema -> Value -> [ValidatorFailure] lateral schema = continueValidating referenced visited (SchemaWithURI schema scope) 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,15 +2,13 @@ module Data.JsonSchema.Fetch where import Import --- Hiding is for GHCs before 7.10: -import Prelude hiding (concat, sequence) import Control.Arrow (left) -import Control.Exception (catch) +import Control.Exception (IOException, catch) import Control.Monad (foldM) -import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as H +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Network.HTTP.Client as NC @@ -50,11 +48,14 @@ -- } -- } -- } - , _rsSchemaMap :: !(URISchemaMap schema) + , _rsSchemaMap :: !(HashMap Text schema) + -- ^ Map of URIs to schemas. } deriving (Eq, Show) -- | Keys are URIs (without URI fragments). -type URISchemaMap schema = HashMap Text schema +newtype URISchemaMap schema + = URISchemaMap { _unURISchemaMap :: HashMap Text schema } + deriving (Eq, Show) data SchemaWithURI schema = SchemaWithURI { _swSchema :: !schema @@ -68,7 +69,7 @@ getReference :: ReferencedSchemas schema -> Maybe Text -> Maybe schema getReference referenced Nothing = Just (_rsStarting referenced) -getReference referenced (Just t) = H.lookup t (_rsSchemaMap referenced) +getReference referenced (Just t) = HM.lookup t (_rsSchemaMap referenced) -------------------------------------------------- -- * Fetch via HTTP @@ -88,13 +89,13 @@ -> IO (Either HTTPFailure (URISchemaMap schema)) referencesViaHTTP' info sw = do manager <- NC.newManager NC.defaultManagerSettings - let f = referencesMethodAgnostic (get manager) info sw + let f = referencesMethodAgnostic (getURL manager) info sw catch (left HTTPParseFailure <$> f) handler where - get :: NC.Manager -> Text -> IO LBS.ByteString - get man url = do + getURL :: NC.Manager -> Text -> IO BS.ByteString + getURL man url = do request <- NC.parseUrlThrow (T.unpack url) - NC.responseBody <$> NC.httpLbs request man + LBS.toStrict . NC.responseBody <$> NC.httpLbs request man handler :: NC.HttpException @@ -107,7 +108,7 @@ data FilesystemFailure = FSParseFailure Text - | FSReadFailure IOError + | FSReadFailure IOException deriving (Show, Eq) referencesViaFilesystem' @@ -118,13 +119,10 @@ referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler where f :: IO (Either Text (URISchemaMap schema)) - f = referencesMethodAgnostic readFile' info sw - - readFile' :: Text -> IO LBS.ByteString - readFile' = fmap LBS.fromStrict . BS.readFile . T.unpack + f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw handler - :: IOError + :: IOException -> IO (Either FilesystemFailure (URISchemaMap schema)) handler = pure . Left . FSReadFailure @@ -137,16 +135,16 @@ -- e.g. rejecting non-local URIs. referencesMethodAgnostic :: forall schema. FromJSON schema - => (Text -> IO LBS.ByteString) + => (Text -> IO BS.ByteString) -> FetchInfo schema -> SchemaWithURI schema -> IO (Either Text (URISchemaMap schema)) referencesMethodAgnostic fetchRef info = - getRecursiveReferences fetchRef info mempty + getRecursiveReferences fetchRef info (URISchemaMap mempty) getRecursiveReferences :: forall schema. FromJSON schema - => (Text -> IO LBS.ByteString) + => (Text -> IO BS.ByteString) -> FetchInfo schema -> URISchemaMap schema -> SchemaWithURI schema @@ -158,21 +156,23 @@ -> SchemaWithURI schema -> IO (Either Text (URISchemaMap schema)) f (Left e) _ = pure (Left e) - f (Right g) (SchemaWithURI schema mUri) = + f (Right (URISchemaMap usm)) (SchemaWithURI schema mUri) = case newRef of - Nothing -> pure (Right g) + Nothing -> pure (Right (URISchemaMap usm)) Just uri -> do bts <- fetchRef uri - case eitherDecode bts of + case eitherDecodeStrict bts of Left e -> pure . Left . T.pack $ e Right schm -> getRecursiveReferences - fetchRef info (H.insert uri schm g) + fetchRef + info + (URISchemaMap (HM.insert uri schm usm)) (SchemaWithURI schm (Just uri)) where newRef :: Maybe Text newRef | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema - = case H.lookup uri g of + = case HM.lookup uri usm of Nothing -> Just uri Just _ -> Nothing | otherwise = Nothing diff --git a/src/Data/JsonSchema/Types.hs b/src/Data/JsonSchema/Types.hs --- a/src/Data/JsonSchema/Types.hs +++ b/src/Data/JsonSchema/Types.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.JsonSchema.Types where -import Prelude import Import -import Data.Validator.Failure (Fail) -import Data.Validator.Types (Validator(..)) +import Data.Validator.Types (Validator(..)) newtype Spec schema err = Spec { _unSpec :: [Validator schema schema err] } @@ -25,8 +22,9 @@ :: Spec schema err -> schema -> Value - -> [Fail err] -validate spec schema v = _unSpec spec >>= (\val -> _validate val schema v) + -> [err] +validate spec schema v = + (\val -> _validate val schema v) =<< _unSpec spec -- | A basic schema type that doesn't impose much structure. -- diff --git a/src/Data/Validator/Draft4.hs b/src/Data/Validator/Draft4.hs --- a/src/Data/Validator/Draft4.hs +++ b/src/Data/Validator/Draft4.hs @@ -1,38 +1,36 @@ -- | Turn the validation functions into actual 'Validator's. --- --- From this point on they know how to parse themselves from JSON --- and also know how to extract subschemas embedded within themselves. -module Data.Validator.Draft4 where +module Data.Validator.Draft4 + ( module Data.Validator.Draft4 + , module Export + ) where -import Prelude import Import -import Data.Aeson.Types (Parser) import qualified Data.HashMap.Strict as HM -import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (catMaybes, isNothing, - maybe, maybeToList) -import Data.Scientific (Scientific) +import Data.Maybe (catMaybes, maybe, maybeToList) import Data.Text (Text) -import qualified Data.Validator.Draft4.Any as AN -import qualified Data.Validator.Draft4.Array as AR -import qualified Data.Validator.Draft4.Number as NU -import qualified Data.Validator.Draft4.Object as OB -import qualified Data.Validator.Draft4.String as ST -import Data.Validator.Failure (Fail(..)) +import Data.Validator.Draft4.Any as Export +import Data.Validator.Draft4.Array as Export +import Data.Validator.Draft4.Number as Export +import Data.Validator.Draft4.Object as Export +import Data.Validator.Draft4.String as Export import Data.Validator.Types (Validator(..)) import Data.Validator.Utils (fromJSONEither) -- | For internal use. -run :: FromJSON b => (a -> b -> [c]) -> Maybe a -> Value -> [c] +-- +-- Take a validation function, a possibly existing validator, and some data. +-- If the validator is exists and can validate the type of data we have, +-- attempt to do so and return any failures. +run :: FromJSON b => (a -> b -> Maybe c) -> Maybe a -> Value -> [c] run _ Nothing _ = mempty run f (Just a) b = case fromJSONEither b of Left _ -> mempty - Right c -> f a c + Right c -> maybeToList (f a c) -- | For internal use. noEmbedded :: a -> ([b], [b]) @@ -42,190 +40,116 @@ -- * Numbers -------------------------------------------------- -newtype MultipleOf - = MultipleOf { _unMultipleOf :: Scientific } - deriving (Eq, Show) - -instance FromJSON MultipleOf where - parseJSON = withObject "MultipleOf" $ \o -> - MultipleOf <$> o .: "multipleOf" - -multipleOf :: Validator a (Maybe MultipleOf) () -multipleOf = - Validator - noEmbedded - (run (fmap maybeToList . NU.multipleOf . _unMultipleOf)) - -data MaximumContext - = MaximumContext Bool Scientific - deriving (Eq, Show) - -instance FromJSON MaximumContext where - parseJSON = withObject "MaximumContext" $ \o -> MaximumContext - <$> o .:! "exclusiveMaximum" .!= False - <*> o .: "maximum" - -maximumVal :: Validator a (Maybe MaximumContext) NU.MaximumInvalid -maximumVal = - Validator - noEmbedded - (run (\(MaximumContext a b) -> maybeToList . NU.maximumVal a b)) - -data MinimumContext - = MinimumContext Bool Scientific - deriving (Eq, Show) +multipleOfValidator :: Validator a (Maybe MultipleOf) MultipleOfInvalid +multipleOfValidator = Validator noEmbedded (run multipleOfVal) -instance FromJSON MinimumContext where - parseJSON = withObject "MinimumContext" $ \o -> MinimumContext - <$> o .:! "exclusiveMinimum" .!= False - <*> o .: "minimum" +maximumValidator :: Validator a (Maybe Maximum) MaximumInvalid +maximumValidator = Validator noEmbedded (run maximumVal) -minimumVal :: Validator a (Maybe MinimumContext) NU.MinimumInvalid -minimumVal = - Validator - noEmbedded - (run (\(MinimumContext a b) -> maybeToList . NU.minimumVal a b)) +minimumValidator :: Validator a (Maybe Minimum) MinimumInvalid +minimumValidator = Validator noEmbedded (run minimumVal) -------------------------------------------------- -- * Strings -------------------------------------------------- -newtype MaxLength - = MaxLength { _unMaxLength :: Int } - deriving (Eq, Show) - -instance FromJSON MaxLength where - parseJSON = withObject "MaxLength" $ \o -> - MaxLength <$> o .: "maxLength" - -maxLength :: Validator a (Maybe MaxLength) () -maxLength = - Validator - noEmbedded - (run (fmap maybeToList . ST.maxLength . _unMaxLength)) - -newtype MinLength - = MinLength { _unMinLength :: Int } - deriving (Eq, Show) - -instance FromJSON MinLength where - parseJSON = withObject "MinLength" $ \o -> - MinLength <$> o .: "minLength" - -minLength :: Validator a (Maybe MinLength) () -minLength = - Validator - noEmbedded - (run (fmap maybeToList . ST.minLength . _unMinLength)) - -newtype PatternVal - = PatternVal { _unPatternVal :: Text } - deriving (Eq, Show) +maxLengthValidator :: Validator a (Maybe MaxLength) MaxLengthInvalid +maxLengthValidator = Validator noEmbedded (run maxLengthVal) -instance FromJSON PatternVal where - parseJSON = withObject "PatternVal" $ \o -> - PatternVal <$> o .: "pattern" +minLengthValidator :: Validator a (Maybe MinLength) MinLengthInvalid +minLengthValidator = Validator noEmbedded (run minLengthVal) -patternVal :: Validator a (Maybe PatternVal) () -patternVal = - Validator - noEmbedded - (run (fmap maybeToList . ST.patternVal . _unPatternVal)) +patternValidator :: Validator a (Maybe PatternValidator) PatternInvalid +patternValidator = Validator noEmbedded (run patternVal) -------------------------------------------------- -- * Arrays -------------------------------------------------- -newtype MaxItems - = MaxItems { _unMaxItems :: Int } - deriving (Eq, Show) - -instance FromJSON MaxItems where - parseJSON = withObject "MaxItems" $ \o -> - MaxItems <$> o .: "maxItems" - -maxItems :: Validator a (Maybe MaxItems) () -maxItems = - Validator - noEmbedded - (run (fmap maybeToList . AR.maxItems . _unMaxItems)) +maxItemsValidator :: Validator a (Maybe MaxItems) MaxItemsInvalid +maxItemsValidator = Validator noEmbedded (run maxItemsVal) -newtype MinItems - = MinItems { _unMinItems :: Int } - deriving (Eq, Show) +minItemsValidator :: Validator a (Maybe MinItems) MinItemsInvalid +minItemsValidator = Validator noEmbedded (run minItemsVal) -instance FromJSON MinItems where - parseJSON = withObject "MinItems" $ \o -> - MinItems <$> o .: "minItems" +uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid +uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal) -minItems :: Validator a (Maybe MinItems) () -minItems = +itemsRelatedValidator + :: (schema -> Value -> [err]) + -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err) +itemsRelatedValidator f = Validator - noEmbedded - (run (fmap maybeToList . AR.minItems . _unMinItems)) - -newtype UniqueItems - = UniqueItems { _unUniqueItems :: Bool } - deriving (Eq, Show) + (\a -> ( mempty + , case _irItems a of + Just (ItemsObject b) -> pure b + Just (ItemsArray cs) -> cs + Nothing -> mempty + <> case _irAdditional a of + Just (AdditionalObject b) -> pure b + _ -> mempty + )) + (\a b -> case fromJSONEither b of + Left _ -> mempty + Right c -> itemsRelatedVal f a c) -instance FromJSON UniqueItems where - parseJSON = withObject "UniqueItems" $ \o -> - UniqueItems <$> o .: "uniqueItems" +-------------------------------------------------- +-- * Objects +-------------------------------------------------- -uniqueItems :: Validator a (Maybe UniqueItems) () -uniqueItems = - Validator - noEmbedded - (run (fmap maybeToList . AR.uniqueItems . _unUniqueItems)) +maxPropertiesValidator + :: Validator + a + (Maybe MaxProperties) + MaxPropertiesInvalid +maxPropertiesValidator = Validator noEmbedded (run maxPropertiesVal) -data ItemsContext schema = - ItemsContext - (Maybe (AR.AdditionalItems schema)) - (AR.Items schema) - deriving (Eq, Show) +minPropertiesValidator + :: Validator + a + (Maybe MinProperties) + MinPropertiesInvalid +minPropertiesValidator = Validator noEmbedded (run minPropertiesVal) -instance FromJSON schema => FromJSON (ItemsContext schema) where - parseJSON = withObject "ItemsContext" $ \o -> ItemsContext - <$> o .:! "additionalItems" - <*> o .: "items" +requiredValidator :: Validator a (Maybe Required) () +requiredValidator = Validator noEmbedded (run requiredVal) -items - :: (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (ItemsContext schema)) (AR.ItemsInvalid err) -items f = +dependenciesValidator + :: (schema -> Value -> [err]) + -> Validator + schema + (Maybe (DependenciesValidator schema)) + (DependenciesInvalid err) +dependenciesValidator f = Validator - (\a -> case a of - Nothing -> mempty - Just (ItemsContext _ b) -> - case b of - AR.ItemsObject c -> (mempty, pure c) - AR.ItemsArray cs -> (mempty, cs)) - (run (\(ItemsContext a b) -> AR.items f a b)) - -newtype AdditionalItemsContext schema - = AdditionalItemsContext - { _unAdditionalItemsContext :: AR.AdditionalItems schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AdditionalItemsContext schema) where - parseJSON = withObject "AdditionalItemsContext" $ \o -> - AdditionalItemsContext <$> o .: "additionalItems" + (maybe mempty ( (\a -> (mempty, a)) + . catMaybes . fmap checkDependency + . HM.elems . _unDependenciesValidator + )) + (run (dependenciesVal f)) + where + checkDependency :: Dependency schema -> Maybe schema + checkDependency (PropertyDependency _) = Nothing + checkDependency (SchemaDependency s) = Just s --- | Since 'items' will always take care of validating 'additionalItems' --- as well, the actual validation side of 'additionalItemsEmbedded' is --- disabled. -additionalItemsEmbedded - :: Validator +propertiesRelatedValidator + :: (schema -> Value -> [err]) + -> Validator schema - (Maybe (AdditionalItemsContext schema)) - err -additionalItemsEmbedded= + (PropertiesRelated schema) + (PropertiesRelatedInvalid err) +propertiesRelatedValidator f = Validator - (\a -> case a of - Just (AdditionalItemsContext (AR.AdditionalObject b)) -> - (mempty, pure b) - _ -> (mempty, mempty)) - (const (const mempty)) + (\a -> ( mempty + , HM.elems (fromMaybe mempty (_propProperties a)) + <> HM.elems (fromMaybe mempty (_propPattern a)) + <> case _propAdditional a of + Just (AdditionalPropertiesObject b) -> [b] + _ -> mempty + )) + (\a b -> case fromJSONEither b of + Left _ -> mempty + Right c -> maybeToList (propertiesRelatedVal f a c)) newtype Definitions schema = Definitions { _unDefinitions :: HashMap Text schema } @@ -235,11 +159,9 @@ parseJSON = withObject "Definitions" $ \o -> Definitions <$> o .: "definitions" --- | Placing this here since it's similar to @"additionalItems"@. --- in that its validator doesn't run. --- --- TODO: Add tests to the language agnostic test suite for both --- @"additionalItems"@ and this. +-- TODO: Add tests to the language agnostic test suite to +-- make sure these schemas are embedded correctly +-- (and do so for @"additionalItems"@ as well). definitionsEmbedded :: Validator schema @@ -253,298 +175,68 @@ (const (const mempty)) -------------------------------------------------- --- * Objects --------------------------------------------------- - -newtype MaxProperties - = MaxProperties { _unMaxProperties :: Int } - deriving (Eq, Show) - -instance FromJSON MaxProperties where - parseJSON = withObject "MaxProperties" $ \o -> - MaxProperties <$> o .: "maxProperties" - -maxProperties :: Validator a (Maybe MaxProperties) () -maxProperties = - Validator - noEmbedded - (run (fmap maybeToList . OB.maxProperties . _unMaxProperties)) - -newtype MinProperties - = MinProperties { _unMinProperties :: Int } - deriving (Eq, Show) - -instance FromJSON MinProperties where - parseJSON = withObject "MinProperties" $ \o -> - MinProperties <$> o .: "minProperties" - -minProperties :: Validator a (Maybe MinProperties) () -minProperties = - Validator - noEmbedded - (run (fmap maybeToList . OB.minProperties . _unMinProperties)) - -newtype RequiredContext - = RequiredContext { _unRequiredContext :: OB.Required } - deriving (Eq, Show) - -instance FromJSON RequiredContext where - parseJSON = withObject "RequiredContext" $ \o -> - RequiredContext <$> o .: "required" - -required :: Validator a (Maybe RequiredContext) () -required = - Validator - noEmbedded - (run (fmap maybeToList . OB.required . _unRequiredContext)) - -newtype DependenciesContext schema - = DependenciesContext - { _unDependenciesContext :: HashMap Text (OB.Dependency schema) } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (DependenciesContext schema) where - parseJSON = withObject "DependenciesContext" $ \o -> - DependenciesContext <$> o .: "dependencies" - -dependencies - :: (schema -> Value -> [Fail err]) - -> Validator - schema - (Maybe (DependenciesContext schema)) - (OB.DependencyInvalid err) -dependencies f = - Validator - (maybe mempty ( (\a -> (mempty, a)) - . catMaybes . fmap checkDependency - . HM.elems . _unDependenciesContext - )) - (run (OB.dependencies f . _unDependenciesContext)) - where - checkDependency :: OB.Dependency schema -> Maybe schema - checkDependency (OB.PropertyDependency _) = Nothing - checkDependency (OB.SchemaDependency s) = Just s - -data PropertiesContext schema - = PropertiesContext - (Maybe (HashMap Text schema)) - (Maybe (OB.AdditionalProperties schema)) - (HashMap Text schema) - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (PropertiesContext schema) where - parseJSON = withObject "PropertiesContext" $ \o -> PropertiesContext - <$> o .:! "patternProperties" - <*> o .:! "additionalProperties" - <*> o .: "properties" - -properties - :: (schema -> Value -> [Fail err]) - -> Validator - schema - (Maybe (PropertiesContext schema)) - (OB.PropertiesInvalid err) -properties f = - Validator - (\a -> case a of - Just (PropertiesContext _ _ b) -> (mempty, HM.elems b) - Nothing -> (mempty, mempty)) - (run (\(PropertiesContext a b c) -> OB.properties f a b c)) - --- | The first argument is whether the validator should be run. --- If @"properties"@ exists it will be parsed to 'False'. -data PatternPropertiesContext schema - = PatternPropertiesContext - Bool - (Maybe (OB.AdditionalProperties schema)) - (HashMap Text schema) - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (PatternPropertiesContext schema) where - parseJSON = withObject "PatternPropertiesContext" $ \o -> - PatternPropertiesContext - <$> shouldRun o - <*> o .:! "additionalProperties" - <*> o .: "patternProperties" - where - shouldRun :: HashMap Text Value -> Parser Bool - shouldRun o = do - a <- o .:! "properties" - pure $ isNothing (a :: Maybe (HashMap Text schema)) - -patternProperties - :: (schema -> Value -> [Fail err]) - -> Validator - schema - (Maybe (PatternPropertiesContext schema)) - (OB.PatternPropertiesInvalid err) -patternProperties f = - Validator - (\a -> case a of - Just (PatternPropertiesContext _ _ b) -> (mempty, HM.elems b) - Nothing -> (mempty, mempty)) - (run (\(PatternPropertiesContext a b c) -> OB.patternProperties f a b c)) - --- | The first argument is whether the validator should be run. --- If @"properties"@ or @"patternProperties"@ exist it will be parsed --- to 'False'. -data AdditionalPropertiesContext schema - = AdditionalPropertiesContext - Bool - (OB.AdditionalProperties schema) - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AdditionalPropertiesContext schema) where - parseJSON = withObject "AdditionalPropertiesContext" $ \o -> - AdditionalPropertiesContext - <$> shouldRun o - <*> o .: "additionalProperties" - where - shouldRun :: HashMap Text Value -> Parser Bool - shouldRun o = do - a <- o .:! "properties" - b <- o .:! "patternProperties" - pure $ isNothing (a :: Maybe (HashMap Text schema)) - && isNothing (b :: Maybe (HashMap Text schema)) - -additionalProperties - :: (schema -> Value -> [Fail err]) - -> Validator - schema - (Maybe (AdditionalPropertiesContext schema)) - (OB.AdditionalPropertiesInvalid err) -additionalProperties f = - Validator - (\a -> case a of - Nothing -> mempty - Just (AdditionalPropertiesContext _ b) -> - case b of - OB.AdditionalPropertiesBool _ -> (mempty, mempty) - OB.AdditionalPropertiesObject c -> (mempty, pure c)) - (run (\(AdditionalPropertiesContext a b) -> OB.additionalProperties f a b)) - --------------------------------------------------- -- * Any -------------------------------------------------- -newtype Ref - = Ref { _unRef :: Text } - deriving (Eq, Show) - -instance FromJSON Ref where - parseJSON = withObject "Ref" $ \o -> - Ref <$> o .: "$ref" - -ref +refValidator :: (FromJSON schema, ToJSON schema) - => AN.VisitedSchemas + => VisitedSchemas -> Maybe Text -> (Maybe Text -> Maybe schema) - -> (AN.VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err]) - -> Validator a (Maybe Ref) (AN.RefInvalid err) -ref visited scope getRef f = - Validator - noEmbedded - (run (AN.ref visited scope getRef f . _unRef)) - -newtype EnumContext - = EnumContext { _unEnumContext :: AN.EnumVal } - deriving (Eq, Show) - -instance FromJSON EnumContext where - parseJSON = withObject "EnumContext" $ \o -> - EnumContext <$> o .: "enum" - -enumVal :: Validator a (Maybe EnumContext) () -enumVal = - Validator - noEmbedded - (run (fmap maybeToList . AN.enumVal . _unEnumContext)) - -newtype TypeContext - = TypeContext { _unTypeContext :: AN.TypeVal } - deriving (Eq, Show) - -instance FromJSON TypeContext where - parseJSON = withObject "TypeContext" $ \o -> - TypeContext <$> o .: "type" - -typeVal :: Validator a (Maybe TypeContext) () -typeVal = + -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err]) + -> Validator a (Maybe Ref) (RefInvalid err) +refValidator visited scope getRef f = Validator noEmbedded - (run (fmap maybeToList . AN.typeVal . _unTypeContext)) + (run (refVal visited scope getRef f)) -newtype AllOf schema - = AllOf { _unAllOf :: NonEmpty schema } - deriving (Eq, Show) +enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid +enumValidator = Validator noEmbedded (run enumVal) -instance FromJSON schema => FromJSON (AllOf schema) where - parseJSON = withObject "AllOf" $ \o -> - AllOf <$> o .: "allOf" +typeValidator :: Validator a (Maybe TypeContext) TypeValidatorInvalid +typeValidator = Validator noEmbedded (run typeVal) -allOf - :: (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (AllOf schema)) err -allOf f = +allOfValidator + :: (schema -> Value -> [err]) + -> Validator schema (Maybe (AllOf schema)) (AllOfInvalid err) +allOfValidator f = Validator (\a -> case a of Just (AllOf b) -> (NE.toList b, mempty) Nothing -> (mempty, mempty)) - (run (AN.allOf f . _unAllOf)) - -newtype AnyOf schema - = AnyOf { _unAnyOf :: NonEmpty schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AnyOf schema) where - parseJSON = withObject "AnyOf" $ \o -> - AnyOf <$> o .: "anyOf" + (run (allOfVal f)) -anyOf - :: (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (AnyOf schema)) err -anyOf f = +anyOfValidator + :: (schema -> Value -> [err]) + -> Validator schema (Maybe (AnyOf schema)) (AnyOfInvalid err) +anyOfValidator f = Validator (\a -> case a of Just (AnyOf b) -> (NE.toList b, mempty) Nothing -> (mempty, mempty)) - (run (AN.anyOf f . _unAnyOf)) - -newtype OneOf schema - = OneOf { _unOneOf :: NonEmpty schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (OneOf schema) where - parseJSON = withObject "OneOf" $ \o -> - OneOf <$> o .: "oneOf" + (run (anyOfVal f)) -oneOf +oneOfValidator :: ToJSON schema - => (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (OneOf schema)) (AN.OneOfInvalid err) -oneOf f = + => (schema -> Value -> [err]) + -> Validator schema (Maybe (OneOf schema)) (OneOfInvalid err) +oneOfValidator f = Validator (\a -> case a of Just (OneOf b) -> (NE.toList b, mempty) Nothing -> (mempty, mempty)) - (run (AN.oneOf f . _unOneOf)) - -newtype NotVal schema - = NotVal { _unNotVal :: schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (NotVal schema) where - parseJSON = withObject "NotVal" $ \o -> - NotVal <$> o .: "not" + (run (oneOfVal f)) -notVal +notValidator :: ToJSON schema - => (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (NotVal schema)) () -notVal f = + => (schema -> Value -> [err]) + -> Validator + schema + (Maybe (NotValidator schema)) + NotValidatorInvalid +notValidator f = Validator (\a -> case a of - Just (NotVal b) -> (pure b, mempty) - Nothing -> (mempty, mempty)) - (run (fmap maybeToList . AN.notVal f . _unNotVal)) + Just (NotValidator b) -> (pure b, mempty) + Nothing -> (mempty, mempty)) + (run (notVal f)) 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 @@ -1,22 +1,16 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Validator.Draft4.Any where import Import --- Hiding is for GHCs before 7.10: -import Prelude hiding (any, concat, elem) -import Control.Monad -import Data.Aeson.Types (Parser) -import Data.List (partition) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NE -import Data.Maybe import qualified Data.Scientific as SCI +import Data.Semigroup (Semigroup) -- for older GHCs import Data.Set (Set) import qualified Data.Set as S +import qualified JSONPointer as JP -import Data.Validator.Failure (Fail(..)) import qualified Data.Validator.Utils as UT import Data.Validator.Reference (URIBaseAndFragment, resolveFragment, resolveReference) @@ -25,43 +19,61 @@ -- * $ref -------------------------------------------------- +newtype Ref + = Ref { _unRef :: Text } + deriving (Eq, Show) + +instance FromJSON Ref where + parseJSON = withObject "Ref" $ \o -> + Ref <$> o .: "$ref" + data RefInvalid err - = RefResolution - | RefLoop - | RefInvalid err + = RefResolution Text + -- ^ Indicates a reference that failed to resolve. + -- + -- NOTE: The language agnostic test suite doesn't specify if this should + -- cause a validation error or should allow data to pass. We choose to + -- return a validation error. + -- + -- Also note that ideally we would enforce in the type system that any + -- failing references be dealt with before valididation. Then this could + -- be removed entirely. + | RefPointerResolution Text + | RefLoop Text VisitedSchemas URIBaseAndFragment + | RefInvalid Text Value (NonEmpty err) + -- ^ 'Text' is the URI and 'Value' is the linked schema. deriving (Eq, Show) newtype VisitedSchemas = VisitedSchemas { _unVisited :: [URIBaseAndFragment] } - deriving (Eq, Show, Monoid) + deriving (Eq, Show, Semigroup, Monoid) -ref +refVal :: forall err schema. (FromJSON schema, ToJSON schema) => VisitedSchemas -> Maybe Text -> (Maybe Text -> Maybe schema) - -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err]) - -> Text + -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err]) + -> Ref -> Value - -> [Fail (RefInvalid err)] -ref visited scope getRef f reference x - | (mUri, mFragment) `elem` _unVisited visited = - pure $ Failure RefLoop (toJSON reference) mempty x + -> Maybe (RefInvalid err) +refVal visited scope getRef f (Ref reference) x + | (mURI, mFragment) `elem` _unVisited visited = + Just (RefLoop reference visited (mURI, mFragment)) | otherwise = - case getRef mUri of - Nothing -> pure failureDNE + case getRef mURI of + Nothing -> Just (RefResolution reference) Just schema -> case resolveFragment mFragment schema of - Nothing -> pure failureDNE + Nothing -> Just (RefPointerResolution reference) Just s -> - let newVisited = (VisitedSchemas [(mUri, mFragment)] + let newVisited = (VisitedSchemas [(mURI, mFragment)] <> visited) - in fmap RefInvalid <$> f newVisited mUri s x + errs = f newVisited mURI s x + in RefInvalid reference (toJSON schema) + <$> NE.nonEmpty errs where - (mUri, mFragment) = resolveReference scope reference - - failureDNE :: Fail (RefInvalid err) - failureDNE = Failure RefResolution (toJSON reference) mempty x + (mURI, mFragment) = resolveReference scope reference -------------------------------------------------- -- * enum @@ -76,77 +88,84 @@ -- -- NOTE: We don't enforce the uniqueness constraint in the haskell code, -- but we do in the 'FromJSON' instance. -newtype EnumVal - = EnumVal { _unEnumVal :: NonEmpty Value } +newtype EnumValidator + = EnumValidator { _unEnumValidator :: NonEmpty Value } -- Given a choice, we'd prefer to enforce uniqueness through the type -- system over having at least one element. To use a 'Set' though we'd -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values) -- and we'd rather not make users mess with 'OrdValue'. deriving (Eq, Show) -instance FromJSON EnumVal where - parseJSON v = checkUnique . UT._unNonEmpty' =<< parseJSON v - where - checkUnique :: NonEmpty Value -> Parser EnumVal - checkUnique a - | UT.allUniqueValues' a = pure (EnumVal a) - | otherwise = fail "All elements of the Enum validator must be unique." - -instance ToJSON EnumVal where - toJSON = toJSON . UT.NonEmpty' . _unEnumVal +instance FromJSON EnumValidator where + parseJSON = withObject "EnumValidator" $ \o -> + EnumValidator <$> o .: "enum" -instance Arbitrary EnumVal where +instance Arbitrary EnumValidator where arbitrary = do xs <- (fmap.fmap) UT._unArbitraryValue arbitrary case NE.nonEmpty (toUnique xs) of - Nothing -> EnumVal . pure . UT._unArbitraryValue <$> arbitrary - Just ne -> pure (EnumVal ne) + Nothing -> EnumValidator . pure . UT._unArbitraryValue <$> arbitrary + Just ne -> pure (EnumValidator ne) where toUnique :: [Value] -> [Value] toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue -enumVal :: EnumVal -> Value -> Maybe (Fail ()) -enumVal (EnumVal vs) x +data EnumInvalid + = EnumInvalid EnumValidator Value + deriving (Eq, Show) + +enumVal :: EnumValidator -> Value -> Maybe EnumInvalid +enumVal a@(EnumValidator vs) x | not (UT.allUniqueValues' vs) = Nothing | x `elem` vs = Nothing - | otherwise = Just $ Failure () (toJSON (UT.NonEmpty' vs)) - mempty x + | otherwise = Just $ EnumInvalid a x -------------------------------------------------- -- * type -------------------------------------------------- -data TypeVal - = TypeValString Text - | TypeValArray (Set Text) +-- | This is separate from 'TypeValidator' so that 'TypeValidator' can +-- be used to write 'Data.JsonSchema.Draft4.Schema.Schema' without +-- messing up the 'FromJSON' instance of that data type. +newtype TypeContext + = TypeContext { _unTypeContext :: TypeValidator } deriving (Eq, Show) -instance FromJSON TypeVal where - parseJSON v = fmap TypeValString (parseJSON v) - <|> fmap TypeValArray (parseJSON v) +instance FromJSON TypeContext where + parseJSON = withObject "TypeContext" $ \o -> + TypeContext <$> o .: "type" -instance ToJSON TypeVal where - toJSON (TypeValString t) = toJSON t - toJSON (TypeValArray ts) = toJSON ts +data TypeValidator + = TypeValidatorString Text + | TypeValidatorArray (Set Text) + deriving (Eq, Show) -instance Arbitrary TypeVal where - arbitrary = oneof [ TypeValString <$> UT.arbitraryText - , TypeValArray <$> UT.arbitrarySetOfText +instance FromJSON TypeValidator where + parseJSON v = fmap TypeValidatorString (parseJSON v) + <|> fmap TypeValidatorArray (parseJSON v) + +instance ToJSON TypeValidator where + toJSON (TypeValidatorString t) = toJSON t + toJSON (TypeValidatorArray ts) = toJSON ts + +instance Arbitrary TypeValidator where + arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText + , TypeValidatorArray <$> UT.arbitrarySetOfText ] -setFromTypeVal :: TypeVal -> Set Text -setFromTypeVal (TypeValString t) = S.singleton t -setFromTypeVal (TypeValArray ts) = ts +data TypeValidatorInvalid + = TypeValidatorInvalid TypeValidator Value + deriving (Eq, Show) -typeVal :: TypeVal -> Value -> Maybe (Fail ()) -typeVal tv x - | S.null matches = Just (Failure () (toJSON tv) mempty x) +typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid +typeVal (TypeContext tv) x + | S.null matches = Just (TypeValidatorInvalid tv x) | otherwise = Nothing where -- There can be more than one match because a 'Value' can be both a -- @"number"@ and an @"integer"@. matches :: Set Text - matches = S.intersection okTypes (setFromTypeVal tv) + matches = S.intersection okTypes (setFromTypeValidator tv) okTypes :: Set Text okTypes = @@ -161,76 +180,171 @@ then S.fromList ["number", "integer"] else S.singleton "number" +-- | Internal. +setFromTypeValidator :: TypeValidator -> Set Text +setFromTypeValidator (TypeValidatorString t) = S.singleton t +setFromTypeValidator (TypeValidatorArray ts) = ts + -------------------------------------------------- -- * allOf -------------------------------------------------- -allOf - :: (schema -> Value -> [Fail err]) - -> NonEmpty schema +newtype AllOf schema + = AllOf { _unAllOf :: NonEmpty schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (AllOf schema) where + parseJSON = withObject "AllOf" $ \o -> + AllOf <$> o .: "allOf" + +newtype AllOfInvalid err + = AllOfInvalid (NonEmpty (JP.Index, NonEmpty err)) + deriving (Eq, Show) + +allOfVal + :: forall err schema. + (schema -> Value -> [err]) + -> AllOf schema -> Value - -> [Fail err] -allOf f subSchemas x = NE.toList subSchemas >>= flip f x + -> Maybe (AllOfInvalid err) +allOfVal f (AllOf subSchemas) x = AllOfInvalid <$> NE.nonEmpty failures + where + perhapsFailures :: [(JP.Index, [err])] + perhapsFailures = zip (JP.Index <$> [0..]) + (flip f x <$> NE.toList subSchemas) + failures :: [(JP.Index, NonEmpty err)] + failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures + -------------------------------------------------- -- * anyOf -------------------------------------------------- -anyOf +newtype AnyOf schema + = AnyOf { _unAnyOf :: NonEmpty schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (AnyOf schema) where + parseJSON = withObject "AnyOf" $ \o -> + AnyOf <$> o .: "anyOf" + +newtype AnyOfInvalid err + = AnyOfInvalid (NonEmpty (JP.Index, NonEmpty err)) + deriving (Eq, Show) + +anyOfVal :: forall err schema. - (schema -> Value -> [Fail err]) - -> NonEmpty schema + (schema -> Value -> [err]) + -> AnyOf schema -> Value - -> [Fail err] -anyOf f subSchemas x - | any null results = mempty - | otherwise = concat results + -> Maybe (AnyOfInvalid err) +anyOfVal f (AnyOf subSchemas) x + -- Replace with @null@ once we drop GHC 7.8: + | any (((==) 0 . length) . snd) perhapsFailures = Nothing + | otherwise = AnyOfInvalid <$> NE.nonEmpty failures where - results :: [[Fail err]] - results = flip f x <$> NE.toList subSchemas + perhapsFailures :: [(JP.Index, [err])] + perhapsFailures = zip (JP.Index <$> [0..]) + (flip f x <$> NE.toList subSchemas) + failures :: [(JP.Index, NonEmpty err)] + failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures + -------------------------------------------------- -- * oneOf -------------------------------------------------- +newtype OneOf schema + = OneOf { _unOneOf :: NonEmpty schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (OneOf schema) where + parseJSON = withObject "OneOf" $ \o -> + OneOf <$> o .: "oneOf" + data OneOfInvalid err - = TooManySuccesses - | NoSuccesses err + = TooManySuccesses (NonEmpty (JP.Index, Value)) Value + -- ^ The NonEmpty lists contains tuples whose contents + -- are the index of a schema that validated the data + -- and the contents of that schema. + | NoSuccesses (NonEmpty (JP.Index, NonEmpty err)) Value + -- ^ The NonEmpty lists contains tuples whose contents + -- are the index of a schema that failed to validate the data + -- and the failures it produced. deriving (Eq, Show) -oneOf +oneOfVal :: forall err schema. ToJSON schema - => (schema -> Value -> [Fail err]) - -> NonEmpty schema + => (schema -> Value -> [err]) + -> OneOf schema -> Value - -> [Fail (OneOfInvalid err)] -oneOf f subSchemas x - | length successes == 1 = mempty - | length successes > 1 = pure tooManySuccesses - | otherwise = fmap NoSuccesses <$> concat failures + -> Maybe (OneOfInvalid err) +oneOfVal f (OneOf (firstSubSchema :| otherSubSchemas)) x = + -- Producing the NonEmpty lists needed by the error constructors + -- is a little tricky. If we had a partition function like this + -- it might help: + -- @ + -- (a -> Either b c) -> NonEmpty a -> Either (NonEmpty b, [c]) + -- ([b], NonEmpty c) + -- @ + case (firstSuccess, otherSuccesses) of + (Right _, Nothing) -> Nothing + (Right a, Just successes) -> Just (TooManySuccesses + (a NE.<| successes) x) + (Left e, Nothing) -> Just (NoSuccesses (e :| otherFailures) x) + (Left _, Just (_ :| [])) -> Nothing + (Left _, Just successes) -> Just (TooManySuccesses successes x) where - (successes, failures) = partition null results + firstSuccess :: Either (JP.Index, NonEmpty err) (JP.Index, Value) + firstSuccess = + case NE.nonEmpty (f firstSubSchema x) of + Nothing -> Right (JP.Index 0, toJSON firstSubSchema) + Just errs -> Left (JP.Index 0, errs) - results :: [[Fail err]] - results = flip f x <$> NE.toList subSchemas + otherPerhapsFailures :: [(JP.Index, Value, [err])] + otherPerhapsFailures = + zipWith + (\index schema -> (index, toJSON schema, f schema x)) + (JP.Index <$> [0..]) + otherSubSchemas - -- NOTE: This could also return information about the specific - -- validators that succeeded. - tooManySuccesses :: Fail (OneOfInvalid err) - tooManySuccesses = Failure TooManySuccesses - (toJSON (UT.NonEmpty' subSchemas)) mempty x + otherSuccesses :: Maybe (NonEmpty (JP.Index, Value)) + otherSuccesses = NE.nonEmpty + $ mapMaybe (\(index,val,errs) -> + case errs of + [] -> Just (index,val) + _ -> Nothing + ) otherPerhapsFailures + otherFailures :: [(JP.Index, NonEmpty err)] + otherFailures = mapMaybe (traverse NE.nonEmpty . mid) otherPerhapsFailures + + mid :: (a,b,c) -> (a,c) + mid (a,_,c) = (a,c) + -------------------------------------------------- -- * not -------------------------------------------------- +newtype NotValidator schema + = NotValidator { _unNotValidator :: schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (NotValidator schema) where + parseJSON = withObject "NotValidator" $ \o -> + NotValidator <$> o .: "not" + +data NotValidatorInvalid + = NotValidatorInvalid Value Value + deriving (Eq, Show) + notVal - :: ToJSON schema - => (schema -> Value -> [Fail err]) - -> schema + :: ToJSON schema => + (schema -> Value -> [err]) + -> NotValidator schema -> Value - -> Maybe (Fail ()) -notVal f schema x = + -> Maybe NotValidatorInvalid +notVal f (NotValidator schema) x = case f schema x of - [] -> Just (Failure () (toJSON schema) mempty x) + [] -> Just (NotValidatorInvalid (toJSON schema) x) _ -> 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 @@ -2,53 +2,101 @@ module Data.Validator.Draft4.Array where import Import -import Prelude -import Control.Monad -import qualified Data.Aeson.Pointer as AP -import qualified Data.Text as T -import qualified Data.Vector as V -import Text.Read (readMaybe) +import qualified Data.List.NonEmpty as NE +import qualified Data.Vector as V +import qualified JSONPointer as JP -import Data.Validator.Failure (Fail(..), prependToPath) -import Data.Validator.Utils (allUniqueValues) +import Data.Validator.Utils (allUniqueValues) -------------------------------------------------- -- * maxItems -------------------------------------------------- +newtype MaxItems + = MaxItems { _unMaxItems :: Int } + deriving (Eq, Show) + +instance FromJSON MaxItems where + parseJSON = withObject "MaxItems" $ \o -> + MaxItems <$> o .: "maxItems" + +data MaxItemsInvalid + = MaxItemsInvalid MaxItems (Vector Value) + deriving (Eq, Show) + -- | The spec requires @"maxItems"@ to be non-negative. -maxItems :: Int -> Vector Value -> Maybe (Fail ()) -maxItems n xs +maxItemsVal :: MaxItems -> Vector Value -> Maybe MaxItemsInvalid +maxItemsVal a@(MaxItems n) xs | n < 0 = Nothing - | V.length xs > n = Just (Failure () (toJSON n) mempty (Array xs)) + | V.length xs > n = Just (MaxItemsInvalid a xs) | otherwise = Nothing -------------------------------------------------- -- * minItems -------------------------------------------------- +newtype MinItems + = MinItems { _unMinItems :: Int } + deriving (Eq, Show) + +instance FromJSON MinItems where + parseJSON = withObject "MinItems" $ \o -> + MinItems <$> o .: "minItems" + +data MinItemsInvalid + = MinItemsInvalid MinItems (Vector Value) + deriving (Eq, Show) + -- | The spec requires @"minItems"@ to be non-negative. -minItems :: Int -> Vector Value -> Maybe (Fail ()) -minItems n xs +minItemsVal :: MinItems -> Vector Value -> Maybe MinItemsInvalid +minItemsVal a@(MinItems n) xs | n < 0 = Nothing - | V.length xs < n = Just (Failure () (toJSON n) mempty (Array xs)) + | V.length xs < n = Just (MinItemsInvalid a xs) | otherwise = Nothing -------------------------------------------------- -- * uniqueItems -------------------------------------------------- -uniqueItems :: Bool -> Vector Value -> Maybe (Fail ()) -uniqueItems True xs +newtype UniqueItems + = UniqueItems { _unUniqueItems :: Bool } + deriving (Eq, Show) + +instance FromJSON UniqueItems where + parseJSON = withObject "UniqueItems" $ \o -> + UniqueItems <$> o .: "uniqueItems" + +data UniqueItemsInvalid + = UniqueItemsInvalid (Vector Value) + deriving (Eq, Show) + +uniqueItemsVal :: UniqueItems -> Vector Value -> Maybe UniqueItemsInvalid +uniqueItemsVal (UniqueItems True) xs | allUniqueValues xs = Nothing - | otherwise = Just (Failure () (Bool True) mempty (Array xs)) -uniqueItems False _ = Nothing + | otherwise = Just (UniqueItemsInvalid xs) +uniqueItemsVal (UniqueItems False) _ = Nothing -------------------------------------------------- -- * items -------------------------------------------------- +data ItemsRelated schema = ItemsRelated + { _irItems :: Maybe (Items schema) + , _irAdditional :: Maybe (AdditionalItems schema) + } deriving (Eq, Show) + +instance FromJSON schema => FromJSON (ItemsRelated schema) where + parseJSON = withObject "ItemsRelated" $ \o -> ItemsRelated + <$> o .:! "items" + <*> o .:! "additionalItems" + +emptyItems :: ItemsRelated schema +emptyItems = ItemsRelated + { _irItems = Nothing + , _irAdditional = Nothing + } + data Items schema = ItemsObject schema | ItemsArray [schema] @@ -67,82 +115,73 @@ , ItemsArray <$> arbitrary ] +data ItemsRelatedInvalid err + = IRInvalidItems (ItemsInvalid err) + | IRInvalidAdditional (AdditionalItemsInvalid err) + deriving (Eq, Show) + data ItemsInvalid err - = Items err - | AdditionalItemsBoolInvalid - | AdditionalItemsObjectInvalid err + = ItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err)) + | ItemsArrayInvalid (NonEmpty (JP.Index, NonEmpty err)) deriving (Eq, Show) -items +-- | @"additionalItems"@ only matters if @"items"@ exists +-- and is a JSON Array. +itemsRelatedVal :: forall err schema. - (schema -> Value -> [Fail err]) - -> Maybe (AdditionalItems schema) - -> Items schema + (schema -> Value -> [err]) + -> ItemsRelated schema -> Vector Value - -> [Fail (ItemsInvalid err)] -items f _ (ItemsObject subSchema) xs = - zip [0..] (V.toList xs) >>= g - where - g :: (Int, Value) -> [Fail (ItemsInvalid err)] - g (index,x) = fmap Items - . prependToPath (AP.Token (T.pack (show index))) - <$> f subSchema x + -> [ItemsRelatedInvalid err] -- NOTE: 'Data.These' would help here. +itemsRelatedVal f a xs = + let (itemsFailure, remaining) = case _irItems a of + Nothing -> (Nothing, mempty) + Just b -> itemsVal f b xs + additionalFailure = (\b -> additionalItemsVal f b remaining) + =<< _irAdditional a + in catMaybes [ IRInvalidItems <$> itemsFailure + , IRInvalidAdditional <$> additionalFailure + ] -items f mAdditional (ItemsArray subSchemas) xs = - itemFailures <> additionalItemFailures +-- | Internal. +-- +-- This is because 'itemsRelated' handles @"items"@ validation. +itemsVal + :: forall err schema. + (schema -> Value -> [err]) + -> Items schema + -> Vector Value + -> (Maybe (ItemsInvalid err), [(JP.Index, Value)]) + -- ^ The second item in the tuple is the elements of the original + -- JSON Array still remaining to be checked by @"additionalItems"@. +itemsVal f a xs = + case a of + ItemsObject subSchema -> + case NE.nonEmpty (mapMaybe (validateElem subSchema) indexed) of + Nothing -> (Nothing, mempty) + Just errs -> (Just (ItemsObjectInvalid errs), mempty) + ItemsArray subSchemas -> + let remaining = drop (length subSchemas) indexed + res = catMaybes (zipWith validateElem subSchemas indexed) + in case NE.nonEmpty res of + Nothing -> (Nothing, remaining) + Just errs -> (Just (ItemsArrayInvalid errs), remaining) where - indexedValues :: [(Int, Value)] - indexedValues = zip [0..] (V.toList xs) - - itemFailures :: [Fail (ItemsInvalid err)] - itemFailures = join (zipWith g subSchemas indexedValues) - where - g :: schema -> (Int, Value) -> [Fail (ItemsInvalid err)] - g schema (index,x) = fmap Items - . prependToPath (AP.Token (T.pack (show index))) - <$> f schema x - - additionalItemFailures :: [Fail (ItemsInvalid err)] - additionalItemFailures = - case mAdditional of - Nothing -> mempty - Just adi -> fmap correctName - . correctIndexes - <$> additionalItems f adi extras - where - -- It's not great that we convert back to Vector again. - extras :: Vector Value - extras = V.fromList . fmap snd - . drop (length subSchemas) $ indexedValues - - -- Since 'additionalItems' only sees part of the array, but starts - -- indexing from zero, we need to modify the paths it reports to - -- represent invalid data so they actually represent the correct - -- offsets. - correctIndexes - :: Fail (AdditionalItemsInvalid err) - -> Fail (AdditionalItemsInvalid err) - correctIndexes (Failure a b c d) = Failure a b (fixIndex c) d - where - fixIndex :: AP.Pointer -> AP.Pointer - fixIndex (AP.Pointer (tok:toks)) = - case readMaybe . T.unpack . AP._unToken $ tok of - Nothing -> AP.Pointer $ tok:toks - Just n -> AP.Pointer $ - (AP.Token . T.pack . show $ n + length subSchemas):toks - fixIndex (AP.Pointer []) = AP.Pointer [] + indexed :: [(JP.Index, Value)] + indexed = zip (JP.Index <$> [0..]) (V.toList xs) - correctName :: AdditionalItemsInvalid err -> ItemsInvalid err - correctName AdditionalBoolInvalid = AdditionalItemsBoolInvalid - correctName (AdditionalObjectInvalid err) = - AdditionalItemsObjectInvalid err + validateElem + :: schema + -> (JP.Index, Value) + -> Maybe (JP.Index, NonEmpty err) + validateElem schema (index,x) = (index,) <$> NE.nonEmpty (f schema x) -------------------------------------------------- -- * additionalItems -------------------------------------------------- data AdditionalItems schema - = AdditionalBool Bool + = AdditionalBool Bool | AdditionalObject schema deriving (Eq, Show) @@ -160,25 +199,26 @@ ] data AdditionalItemsInvalid err - = AdditionalBoolInvalid - | AdditionalObjectInvalid err + = AdditionalItemsBoolInvalid (NonEmpty (JP.Index, Value)) + | AdditionalItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err)) deriving (Eq, Show) -additionalItems +-- | Internal. +-- +-- This is because 'itemsRelated' handles @"additionalItems"@ validation. +additionalItemsVal :: forall err schema. - (schema -> Value -> [Fail err]) + (schema -> Value -> [err]) -> AdditionalItems schema - -> Vector Value - -> [Fail (AdditionalItemsInvalid err)] -additionalItems _ (AdditionalBool b) xs - | b = mempty - | V.length xs > 0 = pure (Failure AdditionalBoolInvalid (Bool b) - mempty (toJSON xs)) - | otherwise = mempty -additionalItems f (AdditionalObject subSchema) xs = - zip [0..] (V.toList xs) >>= g - where - g :: (Int, Value) -> [Fail (AdditionalItemsInvalid err)] - g (index,x) = fmap AdditionalObjectInvalid - . prependToPath (AP.Token (T.pack (show index))) - <$> f subSchema x + -> [(JP.Index, Value)] + -- ^ The elements remaining to validate after the ones covered by + -- @"items"@ have been removed. + -> Maybe (AdditionalItemsInvalid err) +additionalItemsVal _ (AdditionalBool True) _ = Nothing +additionalItemsVal _ (AdditionalBool False) xs = + AdditionalItemsBoolInvalid <$> NE.nonEmpty xs +additionalItemsVal f (AdditionalObject subSchema) xs = + let res = mapMaybe + (\(index,x) -> (index,) <$> NE.nonEmpty (f subSchema x)) + xs + in AdditionalItemsObjectInvalid <$> NE.nonEmpty res 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 @@ -2,64 +2,83 @@ module Data.Validator.Draft4.Number where import Import -import Prelude -import Data.Fixed (mod') -import Data.Scientific (Scientific) - -import Data.Validator.Failure (Fail(..)) +import Data.Fixed (mod') +import Data.Scientific (Scientific) -------------------------------------------------- -- * multipleOf -------------------------------------------------- +newtype MultipleOf + = MultipleOf { _unMultipleOf :: Scientific } + deriving (Eq, Show) + +instance FromJSON MultipleOf where + parseJSON = withObject "MultipleOf" $ \o -> + MultipleOf <$> o .: "multipleOf" + +data MultipleOfInvalid + = MultipleOfInvalid MultipleOf Scientific + deriving (Eq, Show) + -- | The spec requires @"multipleOf"@ to be positive. -multipleOf :: Scientific -> Scientific -> Maybe (Fail ()) -multipleOf n x +multipleOfVal :: MultipleOf -> Scientific -> Maybe MultipleOfInvalid +multipleOfVal a@(MultipleOf n) x | n <= 0 = Nothing - | x `mod'` n /= 0 = Just (Failure () (toJSON n) mempty (Number x)) + | x `mod'` n /= 0 = Just (MultipleOfInvalid a x) | otherwise = Nothing -------------------------------------------------- -- * maximum -------------------------------------------------- +data Maximum = Maximum + { _maximumExclusive :: Bool + , _maximumValue :: Scientific + } deriving (Eq, Show) + +instance FromJSON Maximum where + parseJSON = withObject "Maximum" $ \o -> Maximum + <$> o .:! "exclusiveMaximum" .!= False + <*> o .: "maximum" + data MaximumInvalid - = Maximum - | ExclusiveMaximum + = MaximumInvalid Maximum Scientific deriving (Eq, Show) maximumVal - :: Bool - -> Scientific + :: Maximum -> Scientific - -> Maybe (Fail MaximumInvalid) -maximumVal exclusive n x - | x `greaterThan` n = Just (Failure err (toJSON n) mempty (Number x)) - | otherwise = Nothing - where - (greaterThan, err) = if exclusive - then ((>=), ExclusiveMaximum) - else ((>), Maximum) + -> Maybe MaximumInvalid +maximumVal a@(Maximum exclusive n) x + | exclusive && x >= n = Just (MaximumInvalid a x) + | x > n = Just (MaximumInvalid a x) + | otherwise = Nothing -------------------------------------------------- -- * minimum -------------------------------------------------- +data Minimum = Minimum + { _minimumExclusive :: Bool + , _minimumValue :: Scientific + } deriving (Eq, Show) + +instance FromJSON Minimum where + parseJSON = withObject "Minimum" $ \o -> Minimum + <$> o .:! "exclusiveMinimum" .!= False + <*> o .: "minimum" + data MinimumInvalid - = Minimum - | ExclusiveMinimum + = MinimumInvalid Minimum Scientific deriving (Eq, Show) minimumVal - :: Bool - -> Scientific + :: Minimum -> Scientific - -> Maybe (Fail MinimumInvalid) -minimumVal exclusive n x - | x `lessThan` n = Just (Failure err (toJSON n) mempty (Number x)) - | otherwise = Nothing - where - (lessThan, err) = if exclusive - then ((<=), ExclusiveMinimum) - else ((<), Minimum) + -> Maybe MinimumInvalid +minimumVal a@(Minimum exclusive n) x + | exclusive && x <= n = Just (MinimumInvalid a x) + | x < n = Just (MinimumInvalid a x) + | otherwise = Nothing 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Validator.Draft4.Object ( module Data.Validator.Draft4.Object @@ -6,41 +5,67 @@ ) where import Import --- Hiding is for GHCs before 7.10: -import Prelude hiding (all, concat, - foldl) -import Data.Aeson.Types (Parser) -import qualified Data.HashMap.Strict as H +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE import Data.Set (Set) import qualified Data.Set as S import qualified Data.Text as T import Data.Validator.Draft4.Object.Properties -import Data.Validator.Failure (Fail(..)) import Data.Validator.Utils -------------------------------------------------- -- * maxProperties -------------------------------------------------- +newtype MaxProperties + = MaxProperties { _unMaxProperties :: Int } + deriving (Eq, Show) + +instance FromJSON MaxProperties where + parseJSON = withObject "MaxProperties" $ \o -> + MaxProperties <$> o .: "maxProperties" + +data MaxPropertiesInvalid + = MaxPropertiesInvalid MaxProperties (HashMap Text Value) + deriving (Eq, Show) + -- | The spec requires @"maxProperties"@ to be non-negative. -maxProperties :: Int -> HashMap Text Value -> Maybe (Fail ()) -maxProperties n x - | n < 0 = Nothing - | H.size x > n = Just (Failure () (toJSON n) mempty (Object x)) - | otherwise = Nothing +maxPropertiesVal + :: MaxProperties + -> HashMap Text Value + -> Maybe MaxPropertiesInvalid +maxPropertiesVal a@(MaxProperties n) x + | n < 0 = Nothing + | HM.size x > n = Just (MaxPropertiesInvalid a x) + | otherwise = Nothing -------------------------------------------------- -- * minProperties -------------------------------------------------- +newtype MinProperties + = MinProperties { _unMinProperties :: Int } + deriving (Eq, Show) + +instance FromJSON MinProperties where + parseJSON = withObject "MinProperties" $ \o -> + MinProperties <$> o .: "minProperties" + +data MinPropertiesInvalid + = MinPropertiesInvalid MinProperties (HashMap Text Value) + deriving (Eq, Show) + -- | The spec requires @"minProperties"@ to be non-negative. -minProperties :: Int -> HashMap Text Value -> Maybe (Fail ()) -minProperties n x - | n < 0 = Nothing - | H.size x < n = Just (Failure () (toJSON n) mempty (Object x)) - | otherwise = Nothing +minPropertiesVal + :: MinProperties + -> HashMap Text Value + -> Maybe MinPropertiesInvalid +minPropertiesVal a@(MinProperties n) x + | n < 0 = Nothing + | HM.size x < n = Just (MinPropertiesInvalid a x) + | otherwise = Nothing -------------------------------------------------- -- * required @@ -51,28 +76,13 @@ -- > The value of this keyword MUST be an array. -- > This array MUST have at least one element. -- > Elements of this array MUST be strings, and MUST be unique. --- --- We don't enfore that 'Required' has at least one element in the --- haskell code, but we do in the 'FromJSON' instance. newtype Required = Required { _unRequired :: Set Text } - deriving (Eq, Show, ToJSON) + deriving (Eq, Show) instance FromJSON Required where - parseJSON v = checkUnique =<< checkSize =<< parseJSON v - where - checkSize :: [Text] -> Parser [Text] - checkSize a - | null a = fail "Required validator must not be empty." - | otherwise = pure a - - checkUnique :: [Text] -> Parser Required - checkUnique a = - let b = S.fromList a - -- NOTE: Can use length instead of S.size in GHC 7.10 or later. - in if length a == S.size b - then pure (Required b) - else fail "All elements of the Required validator must be unique." + parseJSON = withObject "Required" $ \o -> + Required <$> o .: "required" instance Arbitrary Required where arbitrary = do @@ -80,23 +90,31 @@ xs <- (fmap.fmap) T.pack arbitrary pure . Required . S.fromList $ x:xs -required :: Required -> HashMap Text Value -> Maybe (Fail ()) -required (Required ts) x +requiredVal :: Required -> HashMap Text Value -> Maybe () +requiredVal (Required ts) x -- NOTE: When we no longer need to support GHCs before 7.10 -- we can use null from Prelude throughout the library -- instead of specialized versions. - | S.null ts = Nothing - | H.null (H.difference hm x) = Nothing - | otherwise = Just (Failure () (toJSON ts) - mempty (Object x)) + | S.null ts = Nothing + | HM.null (HM.difference hm x) = Nothing + | otherwise = Just () -- TODO where hm :: HashMap Text Bool - hm = foldl (\b a -> H.insert a True b) mempty ts + hm = foldl (\b a -> HM.insert a True b) mempty ts -------------------------------------------------- -- * dependencies -------------------------------------------------- +newtype DependenciesValidator schema + = DependenciesValidator + { _unDependenciesValidator :: HashMap Text (Dependency schema) } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (DependenciesValidator schema) where + parseJSON = withObject "DependenciesValidator" $ \o -> + DependenciesValidator <$> o .: "dependencies" + data Dependency schema = SchemaDependency schema | PropertyDependency (Set Text) @@ -115,11 +133,15 @@ , PropertyDependency <$> arbitrarySetOfText ] -data DependencyInvalid err - = SchemaDependencyInvalid err - | PropertyDependencyInvalid +data DependencyMemberInvalid err + = SchemaDepInvalid (NonEmpty err) + | PropertyDepInvalid (Set Text) (HashMap Text Value) deriving (Eq, Show) +data DependenciesInvalid err + = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err)) + deriving (Eq, Show) + -- | From the spec: -- -- @@ -132,26 +154,26 @@ -- > If the value is an array, it MUST have at least one element. -- > Each element MUST be a string, and elements in the array MUST be unique. -- > This is called a property dependency. -dependencies +dependenciesVal :: forall err schema. - (schema -> Value -> [Fail err]) - -> HashMap Text (Dependency schema) + (schema -> Value -> [err]) + -> DependenciesValidator schema -> HashMap Text Value - -> [Fail (DependencyInvalid err)] -dependencies f hm x = concat . fmap (uncurry g) . H.toList $ hm - where - g :: Text -> Dependency schema -> [Fail (DependencyInvalid err)] - g k (SchemaDependency schema) - | H.member k x = - fmap SchemaDependencyInvalid <$> f schema (Object x) - | otherwise = mempty - g k (PropertyDependency ts) - | H.member k x && not allPresent = - pure $ Failure PropertyDependencyInvalid - (toJSON (H.singleton k ts)) - mempty - (Object x) - | otherwise = mempty - where - allPresent :: Bool - allPresent = all (`H.member` x) ts + -> Maybe (DependenciesInvalid err) +dependenciesVal f (DependenciesValidator hm) x = + let res = HM.mapMaybeWithKey g hm + in if HM.null res + then Nothing + else Just (DependenciesInvalid res) + where + g :: Text -> Dependency schema -> Maybe (DependencyMemberInvalid err) + g k (SchemaDependency schema) + | HM.member k x = SchemaDepInvalid + <$> NE.nonEmpty (f schema (Object x)) + | otherwise = Nothing + g k (PropertyDependency ts) + | HM.member k x && not allPresent = Just (PropertyDepInvalid ts x) + | otherwise = Nothing + where + allPresent :: Bool + allPresent = all (`HM.member` x) ts 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 @@ -2,213 +2,208 @@ module Data.Validator.Draft4.Object.Properties where import Import -import Prelude -import Control.Monad -import qualified Data.Aeson.Pointer as AP -import Data.Functor (($>)) -import qualified Data.HashMap.Strict as HM -import Data.Text.Encoding (encodeUtf8) -import qualified Text.Regex.PCRE.Heavy as RE +import qualified Data.Hashable as HA +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Text.Encoding (encodeUtf8) +import qualified JSONPointer as JP +import qualified Text.Regex.PCRE.Heavy as RE -import Data.Validator.Failure (Fail(..), prependToPath) +data PropertiesRelated schema = PropertiesRelated + { _propProperties :: Maybe (HashMap Text schema) + , _propPattern :: Maybe (HashMap Text schema) + , _propAdditional :: Maybe (AdditionalProperties schema) + } deriving (Eq, Show) --- | For internal use. -newtype Remaining - = Remaining { _unRemaining :: HashMap Text Value } +instance FromJSON schema => FromJSON (PropertiesRelated schema) where + parseJSON = withObject "PropertiesRelated" $ \o -> PropertiesRelated + <$> o .:! "properties" + <*> o .:! "patternProperties" + <*> o .:! "additionalProperties" --------------------------------------------------- --- * properties --------------------------------------------------- +emptyProperties :: PropertiesRelated schema +emptyProperties = PropertiesRelated + { _propProperties = Nothing + , _propPattern = Nothing + , _propAdditional = Nothing + } -data PropertiesInvalid err - = PropertiesInvalid err - | PropPatternInvalid err - | PropAdditionalInvalid (AdditionalPropertiesInvalid err) +data AdditionalProperties schema + = AdditionalPropertiesBool Bool + | AdditionalPropertiesObject schema deriving (Eq, Show) --- | In order of what's tried: @"properties"@, @"patternProperties"@, --- @"additionalProperties"@. -properties - :: forall err schema. - (schema -> Value -> [Fail err]) - -> Maybe (HashMap Text schema) - -> Maybe (AdditionalProperties schema) - -> HashMap Text schema - -> HashMap Text Value - -> [Fail (PropertiesInvalid err)] -properties f mPat mAdd propertiesHm x = - fmap (fmap PropertiesInvalid) propFailures - <> fmap (fmap PropPatternInvalid) patternFailures - <> fmap (fmap PropAdditionalInvalid) additionalFailures - where - propertiesAndUnmatched :: ([Fail err], Remaining) - propertiesAndUnmatched = ( failures - , Remaining (HM.difference x propertiesHm) - ) - where - failures :: [Fail err] - failures = HM.toList (HM.intersectionWith f propertiesHm x) - >>= (\(k,vs) -> fmap (prependToPath (AP.Token k)) vs) - - (propFailures, remaining1) = propertiesAndUnmatched +instance FromJSON schema => FromJSON (AdditionalProperties schema) where + parseJSON v = fmap AdditionalPropertiesBool (parseJSON v) + <|> fmap AdditionalPropertiesObject (parseJSON v) - mPatProp :: Maybe (HashMap Text Value -> ([Fail err], Remaining)) - mPatProp = patternAndUnmatched f <$> mPat +instance ToJSON schema => ToJSON (AdditionalProperties schema) where + toJSON (AdditionalPropertiesBool b) = toJSON b + toJSON (AdditionalPropertiesObject hm) = toJSON hm - patternFailures :: [Fail err] - patternFailures = case mPatProp of - Nothing -> mempty - Just val -> fst (val x) +instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where + arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary + , AdditionalPropertiesObject <$> arbitrary + ] - remaining2 :: Remaining - remaining2 = case mPatProp of - Nothing -> remaining1 - Just val -> snd . val . _unRemaining $ remaining1 +-- | A glorified @type@ alias. +newtype Regex + = Regex { _unRegex :: Text } + deriving (Eq, Show, Generic) - additionalFailures :: [Fail (AdditionalPropertiesInvalid err)] - additionalFailures = - case mAdd of - Nothing -> mempty - Just a -> additionalProperties f True a (_unRemaining remaining2) +instance HA.Hashable Regex --------------------------------------------------- --- * patternProperties --------------------------------------------------- +-- NOTE: We'd like to enforce that at least one error exists here. +data PropertiesRelatedInvalid err = PropertiesRelatedInvalid + { _prInvalidProperties :: HashMap Text [err] + , _prInvalidPattern :: HashMap (Regex, JP.Key) [err] + , _prInvalidAdditional :: Maybe (APInvalid err) + } deriving (Eq, Show) -data PatternPropertiesInvalid err - = PPInvalid err - | PPAdditionalPropertiesInvalid (AdditionalPropertiesInvalid err) +data APInvalid err + = APBoolInvalid (HashMap Text Value) + | APObjectInvalid (HashMap Text (NonEmpty err)) deriving (Eq, Show) -patternProperties +-- | First @"properties"@ and @"patternProperties"@ are run simultaneously +-- on the data, then @"additionalProperties"@ is run on the remainder. +propertiesRelatedVal :: forall err schema. - (schema -> Value -> [Fail err]) - -> Bool - -> Maybe (AdditionalProperties schema) - -> HashMap Text schema + (schema -> Value -> [err]) + -> PropertiesRelated schema -> HashMap Text Value - -> [Fail (PatternPropertiesInvalid err)] -patternProperties _ False _ _ _ = mempty -patternProperties f _ mAdd patternPropertiesHm x = - (fmap PPInvalid <$> ppFailures) - <> (fmap PPAdditionalPropertiesInvalid <$> addFailures) + -> Maybe (PropertiesRelatedInvalid err) +propertiesRelatedVal f props x + | all null (HM.elems propFailures) + && all null (HM.elems patFailures) + && isNothing addFailures = Nothing + | otherwise = + Just PropertiesRelatedInvalid + { _prInvalidProperties = propFailures + , _prInvalidPattern = patFailures + , _prInvalidAdditional = addFailures + } where - patternProps :: ([Fail err], Remaining) - patternProps = patternAndUnmatched f patternPropertiesHm x + propertiesHm :: HashMap Text schema + propertiesHm = fromMaybe mempty (_propProperties props) - (ppFailures, remaining) = patternProps + patHm :: HashMap Text schema + patHm = fromMaybe mempty (_propPattern props) - addFailures :: [Fail (AdditionalPropertiesInvalid err)] - addFailures = - case mAdd of - Nothing -> mempty - Just a -> additionalProperties f True a (_unRemaining remaining) + propAndUnmatched :: (HashMap Text [err], Remaining) + propAndUnmatched = ( HM.intersectionWith f propertiesHm x + , Remaining (HM.difference x propertiesHm) + ) + (propFailures, propRemaining) = propAndUnmatched + + patAndUnmatched :: (HashMap (Regex, JP.Key) [err], Remaining) + patAndUnmatched = patternAndUnmatched f patHm x + + (patFailures, patRemaining) = patAndUnmatched + + finalRemaining :: Remaining + finalRemaining = Remaining (HM.intersection (_unRemaining patRemaining) + (_unRemaining propRemaining)) + + addFailures :: Maybe (APInvalid err) + addFailures = (\addProp -> additionalProperties f addProp finalRemaining) + =<< _propAdditional props + +-- | Internal. +newtype Remaining + = Remaining { _unRemaining :: HashMap Text Value } + +-- | Internal. patternAndUnmatched :: forall err schema. - (schema -> Value -> [Fail err]) + (schema -> Value -> [err]) -> HashMap Text schema -> HashMap Text Value - -> ([Fail err], Remaining) + -> (HashMap (Regex, JP.Key) [err], Remaining) patternAndUnmatched f patPropertiesHm x = - (HM.foldlWithKey' runVals mempty perhapsMatches, remaining) + (HM.foldlWithKey' runMatches mempty perhapsMatches, remaining) where - perhapsMatches :: HashMap Text (Value, [schema]) - perhapsMatches = HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x + -- @[(Regex, schema)]@ will have one item per match. + perhapsMatches :: HashMap Text ([(Regex, schema)], Value) + perhapsMatches = + HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x where matchingSchemas :: HashMap Text schema - -> HashMap Text (Value, [schema]) + -> HashMap Text ([(Regex, schema)], Value) -> Text -> Value - -> HashMap Text (Value, [schema]) + -> HashMap Text ([(Regex, schema)], Value) matchingSchemas subSchemas acc k v = - HM.insert k (v, HM.foldlWithKey' (checkKey k) mempty subSchemas) acc + HM.insert k + (HM.foldlWithKey' (checkKey k) mempty subSchemas, v) + acc checkKey :: Text - -> [schema] + -> [(Regex, schema)] -> Text -> schema - -> [schema] + -> [(Regex, schema)] checkKey k acc r subSchema = case RE.compileM (encodeUtf8 r) mempty of Left _ -> acc Right re -> if k RE.=~ re - then pure subSchema <> acc + then (Regex r, subSchema) : acc else acc - runVals - :: [Fail err] + runMatches + :: HashMap (Regex, JP.Key) [err] -> Text - -> (Value, [schema]) - -> [Fail err] - runVals acc k (v,subSchemas) = - (subSchemas >>= (\schema -> prependToPath (AP.Token k) <$> f schema v)) - <> acc + -> ([(Regex, schema)], Value) + -> HashMap (Regex, JP.Key) [err] + runMatches acc k (matches,v) = + foldr runMatch acc matches + where + runMatch + :: (Regex, schema) + -> HashMap (Regex, JP.Key) [err] + -> HashMap (Regex, JP.Key) [err] + runMatch (r,schema) = HM.insert (r, JP.Key k) (f schema v) remaining :: Remaining - remaining = Remaining . fmap fst . HM.filter (null . snd) $ perhapsMatches - --------------------------------------------------- --- * additionalProperties --------------------------------------------------- - -data AdditionalProperties schema - = AdditionalPropertiesBool Bool - | AdditionalPropertiesObject schema - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AdditionalProperties schema) where - parseJSON v = fmap AdditionalPropertiesBool (parseJSON v) - <|> fmap AdditionalPropertiesObject (parseJSON v) - -instance ToJSON schema => ToJSON (AdditionalProperties schema) where - toJSON (AdditionalPropertiesBool b) = toJSON b - toJSON (AdditionalPropertiesObject hm) = toJSON hm - -instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where - arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary - , AdditionalPropertiesObject <$> arbitrary - ] - -data AdditionalPropertiesInvalid err - = APBoolInvalid - | APObjectInvalid err - deriving (Eq, Show) + remaining = Remaining . fmap snd . HM.filter (null . fst) $ perhapsMatches +-- Internal. additionalProperties :: forall err schema. - (schema -> Value -> [Fail err]) - -> Bool + (schema -> Value -> [err]) -> AdditionalProperties schema - -> HashMap Text Value - -> [Fail (AdditionalPropertiesInvalid err)] -additionalProperties _ False _ _ = mempty -additionalProperties f _ a x = + -> Remaining + -> Maybe (APInvalid err) +additionalProperties f a x = case a of AdditionalPropertiesBool b -> - ($> APBoolInvalid) <$> additionalPropertiesBool b x + APBoolInvalid <$> additionalPropertiesBool b x AdditionalPropertiesObject b -> - fmap APObjectInvalid <$> additionalPropertiesObject f b x + APObjectInvalid <$> additionalPropertiesObject f b x +-- | Internal. additionalPropertiesBool :: Bool - -> HashMap Text Value - -> [Fail ()] -additionalPropertiesBool False x - | HM.size x > 0 = pure $ Failure () (Bool False) mempty (Object x) - | otherwise = mempty -additionalPropertiesBool True _ = mempty + -> Remaining + -> Maybe (HashMap Text Value) +additionalPropertiesBool True _ = Nothing +additionalPropertiesBool False (Remaining x) + | HM.size x > 0 = Just x + | otherwise = Nothing +-- | Internal. additionalPropertiesObject :: forall err schema. - (schema -> Value -> [Fail err]) + (schema -> Value -> [err]) -> schema - -> HashMap Text Value - -> [Fail err] -additionalPropertiesObject f schema x = HM.toList x >>= g - where - g :: (Text, Value) -> [Fail err] - g (k,v) = prependToPath (AP.Token k) <$> f schema v + -> Remaining + -> Maybe (HashMap Text (NonEmpty err)) +additionalPropertiesObject f schema (Remaining x) = + let errs = HM.mapMaybe (NE.nonEmpty . f schema) x + in if HM.null errs + then Nothing + else Just errs 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 @@ -2,44 +2,78 @@ module Data.Validator.Draft4.String where import Import -import Prelude -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import qualified Text.Regex.PCRE.Heavy as RE - -import Data.Validator.Failure (Fail(..)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Text.Regex.PCRE.Heavy as RE -------------------------------------------------- -- * maxLength -------------------------------------------------- +newtype MaxLength + = MaxLength { _unMaxLength :: Int } + deriving (Eq, Show) + +instance FromJSON MaxLength where + parseJSON = withObject "MaxLength" $ \o -> + MaxLength <$> o .: "maxLength" + +data MaxLengthInvalid + = MaxLengthInvalid MaxLength Text + deriving (Eq, Show) + -- | The spec requires @"maxLength"@ to be non-negative. -maxLength :: Int -> Text -> Maybe (Fail ()) -maxLength n x +maxLengthVal :: MaxLength -> Text -> Maybe MaxLengthInvalid +maxLengthVal a@(MaxLength n) x | n <= 0 = Nothing - | T.length x > n = Just (Failure () (toJSON n) mempty (String x)) + | T.length x > n = Just (MaxLengthInvalid a x) | otherwise = Nothing -------------------------------------------------- -- * minLength -------------------------------------------------- +newtype MinLength + = MinLength { _unMinLength :: Int } + deriving (Eq, Show) + +instance FromJSON MinLength where + parseJSON = withObject "MinLength" $ \o -> + MinLength <$> o .: "minLength" + +data MinLengthInvalid + = MinLengthInvalid MinLength Text + deriving (Eq, Show) + -- | The spec requires @"minLength"@ to be non-negative. -minLength :: Int -> Text -> Maybe (Fail ()) -minLength n x +minLengthVal :: MinLength -> Text -> Maybe MinLengthInvalid +minLengthVal a@(MinLength n) x | n <= 0 = Nothing - | T.length x < n = Just (Failure () (toJSON n) mempty (String x)) + | T.length x < n = Just (MinLengthInvalid a x) | otherwise = Nothing -------------------------------------------------- -- * pattern -------------------------------------------------- -patternVal :: Text -> Text -> Maybe (Fail ()) -patternVal t x = +newtype PatternValidator + = PatternValidator { _unPatternValidator :: Text } + deriving (Eq, Show) + +instance FromJSON PatternValidator where + parseJSON = withObject "PatternValidator" $ \o -> + PatternValidator <$> o .: "pattern" + +data PatternInvalid + = PatternNotRegex -- TODO: let these pass successfully? + | PatternInvalid PatternValidator Text + deriving (Eq, Show) + +patternVal :: PatternValidator -> Text -> Maybe PatternInvalid +patternVal a@(PatternValidator t) x = case RE.compileM (encodeUtf8 t) mempty of - Left _ -> Just (Failure () (toJSON t) mempty (String x)) + Left _ -> Just PatternNotRegex Right re -> if x RE.=~ re then Nothing - else Just (Failure () (toJSON t) mempty (String x)) + else Just (PatternInvalid a x) diff --git a/src/Data/Validator/Failure.hs b/src/Data/Validator/Failure.hs deleted file mode 100644 --- a/src/Data/Validator/Failure.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} - -module Data.Validator.Failure where - -import Import --- Hiding is for GHCs before 7.10: -import Prelude hiding (concat, sequence) - -import qualified Data.Aeson.Pointer as AP - --- | Validators shouldn't know more about the schema they're going to --- be used with than necessary. If a validator throws errors using the --- error sum type of a particular schema, then it can't be used with --- other schemas later that have different error sum types (at least not --- without writing partial functions). --- --- Because of this we make 'Fail' a higher order type, so each validator --- can return a sum type describing only the failures that can occur in that --- validator (or '()' if that validator can only fail in one way). --- --- It's the job of a schema's validate function to unify the errors produced --- by the validators it uses into a single error sum type for that schema. --- The schema's validate function will return a 'Fail' with --- that sum type as its type argument. --- --- The slightly weird naming ('Fail' and 'Failure') is so that we can define --- a 'type Failure = Fail SchemaErrorType' for each of our schemas, and --- export it along with 'Fail(..)'. This way the users of the library only --- use 'Failure', not 'Fail'. -data Fail err = Failure - { _failureValidatorsCalled :: !err - -- ^ E.g. @Items UniqueItems@ during draft 4 validation. - , _failureFinalValidator :: !Value - -- ^ The value of the validator that raised the error (e.g. the value of - -- @"uniqueItems"@ in the above example. - , _failureOffendingPointer :: !AP.Pointer - -- ^ A pointer to the part of the data that caused invalidation. - , _failureOffendingData :: !Value - -- ^ The part of the data that caused invalidation. Usually this is - -- identical to the result of resolving '_invalidOffendingPointer' - -- against the starting data, but not always (e.g. in the case of - -- 'additionalItems' where '_invalidOffendingData' will be the items - -- in the array that were not allowed, instead of the entire array). - } deriving (Eq, Show, Functor) - -prependToPath :: AP.Token -> Fail a -> Fail a -prependToPath tok failure = - let old = _failureOffendingPointer failure - in failure { _failureOffendingPointer = AP.Pointer [tok] <> old } 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 @@ -7,14 +7,14 @@ module Data.Validator.Reference where import Import -import Prelude -import qualified Data.Aeson.Pointer as AP import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified JSONPointer as JP import Network.HTTP.Types.URI (urlDecode) import System.FilePath ((), dropFileName) +-- | TODO: Replace these with actual URI data types. type URIBase = Maybe Text type URIBaseAndFragment = (Maybe Text, Maybe Text) @@ -34,8 +34,8 @@ resolveFragment Nothing schema = Just schema resolveFragment (Just pointer) schema = do let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer - p <- either (const Nothing) Just (AP.unescape urlDecoded) - x <- either (const Nothing) Just (AP.resolve p (toJSON schema)) + p <- either (const Nothing) Just (JP.unescape urlDecoded) + x <- either (const Nothing) Just (JP.resolve p (toJSON schema)) case fromJSON x of Error _ -> Nothing Success schema' -> Just schema' diff --git a/src/Data/Validator/Types.hs b/src/Data/Validator/Types.hs --- a/src/Data/Validator/Types.hs +++ b/src/Data/Validator/Types.hs @@ -1,13 +1,9 @@ -{-# LANGUAGE DeriveFunctor #-} module Data.Validator.Types where -import Prelude - -import Data.Aeson (Value) -import Data.Profunctor (Profunctor(..)) +import Import -import Data.Validator.Failure (Fail) +import Data.Profunctor (Profunctor(..)) data Validator schema val err = Validator { _embedded :: val -> ([schema], [schema]) @@ -19,7 +15,7 @@ -- This is done to allow static detection of loops, though this isn't -- implemented yet (though the Draft4 code does do live loop detection -- during validation). - , _validate :: val -> Value -> [Fail err] + , _validate :: val -> Value -> [err] } deriving Functor instance Profunctor (Validator schema) where diff --git a/src/Data/Validator/Utils.hs b/src/Data/Validator/Utils.hs --- a/src/Data/Validator/Utils.hs +++ b/src/Data/Validator/Utils.hs @@ -2,11 +2,9 @@ module Data.Validator.Utils where import Import -import Prelude -import Control.Arrow +import Control.Monad (fail) import qualified Data.HashMap.Strict as HM -import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Scientific (Scientific, fromFloatDigits) import Data.Set (Set) diff --git a/src/Import.hs b/src/Import.hs --- a/src/Import.hs +++ b/src/Import.hs @@ -1,12 +1,12 @@ module Import (module Export) where -import Control.Applicative as Export +import Protolude as Export + import Data.Aeson as Export -import Data.Foldable as Export import Data.HashMap.Strict as Export (HashMap) -import Data.Monoid as Export -import Data.Text as Export (Text) -import Data.Traversable as Export +import Data.List as Export (length, null) -- for older GHCs +import Data.List.NonEmpty as Export (NonEmpty) import Data.Vector as Export (Vector) -import Test.QuickCheck as Export hiding (Failure, Result, Success) +import Test.QuickCheck as Export hiding ((.&.), Failure, + Result, Success) diff --git a/test/Local.hs b/test/Local.hs --- a/test/Local.hs +++ b/test/Local.hs @@ -1,18 +1,17 @@ module Main where -import Control.Applicative -import Control.Monad (unless) +import Protolude + import Data.Aeson -import Data.Foldable (traverse_) -import qualified Data.List.NonEmpty as N -import Data.Monoid +import qualified Data.List.NonEmpty as NE import qualified System.Timeout as TO import Test.Hspec import Test.QuickCheck (property) import qualified Data.JsonSchema.Draft4 as D4 -import Data.JsonSchema.Fetch (ReferencedSchemas(..)) +import Data.JsonSchema.Fetch (ReferencedSchemas(..), + URISchemaMap(..)) import qualified Data.JsonSchema.Types as JT import qualified Local.Failure import qualified Local.Validation @@ -21,13 +20,13 @@ -- Examples import qualified AlternateSchema -import qualified Full import qualified Simple +import qualified TwoStep -dir :: String +dir :: FilePath dir = "JSON-Schema-Test-Suite/tests/draft4" -supplementDir :: String +supplementDir :: FilePath supplementDir = "test/supplement" main :: IO () @@ -73,22 +72,20 @@ res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc) let failures = case res of Right () -> mempty - Left (D4.HVData a) -> N.toList a - other -> error ("Local.validate error: " + Left (D4.HVData a) -> NE.toList (D4._invalidFailures a) + other -> panic ("Local.validate error: " <> show other) - traverse_ (checkPointer (_scData sc)) failures assertResult sc failures validateExample :: JT.Schema -> SchemaTestCase -> Expectation validateExample s sc = do res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing) case res of - Left e -> error ("Local.validateExample error: " <> show e) + Left e -> panic ("Local.validateExample error: " <> show e) Right schemaMap -> do let failures = AlternateSchema.validate - (ReferencedSchemas s schemaMap) + (ReferencedSchemas s (_unURISchemaMap schemaMap)) Nothing s (_scData sc) - traverse_ (checkPointer (_scData sc)) failures assertResult sc failures quickCheckTests :: Spec @@ -101,5 +98,5 @@ exampleTests :: Spec exampleTests = do - it "Full.example compiles successfully" Full.example it "Simple.example compiles successfully" Simple.example + it "TwoStep.example compiles successfully" TwoStep.example diff --git a/test/Local/Failure.hs b/test/Local/Failure.hs --- a/test/Local/Failure.hs +++ b/test/Local/Failure.hs @@ -1,35 +1,41 @@ module Local.Failure where -import Prelude +import Protolude import Data.Aeson -import qualified Data.Aeson.Pointer as P -import Data.Monoid import Test.Hspec +import qualified Data.Vector as V +import qualified JSONPointer as JP import Data.JsonSchema.Draft4 -import Data.JsonSchema.Draft4.Spec (validate) -import qualified Data.Validator.Draft4.Array as AR +import qualified Data.JsonSchema.Draft4.Spec as Spec +import qualified Data.Validator.Draft4 as D4 spec :: Spec spec = do it "items array failures are constructed correctly" itemsArray it "items object failures are constructed correctly" itemsObject + it "reports infinitely looping references correctly" loopRef itemsArray :: Expectation itemsArray = failures `shouldBe` - [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"]) - (toJSON [True, True]) + [ FailureItems (D4.ItemsArrayInvalid ( + pure ( JP.Index 0 + , pure (FailureUniqueItems (D4.UniqueItemsInvalid + (V.fromList [Null, Null]) + )) + ) + )) ] where - failures = validate (ReferencedSchemas schema mempty) - sw (toJSON [[True, True]]) + failures :: [ValidatorFailure] + failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData schema :: Schema schema = emptySchema - { _schemaItems = Just $ AR.ItemsArray + { _schemaItems = Just $ D4.ItemsArray [emptySchema { _schemaUniqueItems = Just True }] } @@ -39,19 +45,27 @@ , _swURI = Nothing } + badData :: Value + badData = toJSON [[Null, Null]] + itemsObject :: Expectation itemsObject = failures `shouldBe` - [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"]) - (toJSON [True, True]) + [ FailureItems (D4.ItemsObjectInvalid ( + pure ( JP.Index 1 + , pure (FailureUniqueItems (D4.UniqueItemsInvalid + (V.fromList [Null, Null]) + )) + ) + )) ] where - failures = validate (ReferencedSchemas schema mempty) - sw (toJSON [[True, True]]) + failures :: [ValidatorFailure] + failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData schema :: Schema schema = emptySchema - { _schemaItems = Just $ AR.ItemsObject + { _schemaItems = Just $ D4.ItemsObject (emptySchema { _schemaUniqueItems = Just True }) } @@ -60,3 +74,33 @@ { _swSchema = schema , _swURI = Nothing } + + badData :: Value + badData = toJSON [Null, toJSON [Null, Null]] + +loopRef :: Expectation +loopRef = + failures `shouldBe` + [ FailureRef (D4.RefLoop + "#" + (D4.VisitedSchemas [(Nothing, Nothing)]) + (Nothing, Nothing) + ) + ] + where + failures :: [ValidatorFailure] + failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData + + schema :: Schema + schema = emptySchema + { _schemaRef = Just "#" + } + + sw :: SchemaWithURI Schema + sw = SchemaWithURI + { _swSchema = schema + , _swURI = Nothing + } + + badData :: Value + badData = toJSON [[Null, Null]] diff --git a/test/Local/Reference.hs b/test/Local/Reference.hs --- a/test/Local/Reference.hs +++ b/test/Local/Reference.hs @@ -1,6 +1,8 @@ module Local.Reference where +import Protolude + import Test.Hspec import Data.Validator.Reference diff --git a/test/Local/Validation.hs b/test/Local/Validation.hs --- a/test/Local/Validation.hs +++ b/test/Local/Validation.hs @@ -1,12 +1,12 @@ module Local.Validation where -import Control.Applicative +import Protolude hiding (msg) + import Data.Aeson import qualified Data.Aeson as AE import qualified Data.HashMap.Strict as HM -import Data.Monoid -import Data.Text (Text) +import Data.String (String) import Test.Hspec import Data.JsonSchema.Draft4 diff --git a/test/Remote.hs b/test/Remote.hs --- a/test/Remote.hs +++ b/test/Remote.hs @@ -1,25 +1,25 @@ module Main where -import Control.Applicative +import Protolude + import Control.Concurrent.Async (withAsync) -import Data.Foldable (traverse_) -import qualified Data.List.NonEmpty as N -import Data.Monoid +import qualified Data.List.NonEmpty as NE import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) import Network.Wai.Handler.Warp (run) import Test.Hspec import qualified Data.JsonSchema.Draft4 as D4 -import Data.JsonSchema.Fetch (ReferencedSchemas(..)) +import Data.JsonSchema.Fetch (ReferencedSchemas(..), + URISchemaMap(..)) import qualified Data.JsonSchema.Types as JT import Shared -- Examples import qualified AlternateSchema -dir :: String +dir :: FilePath dir = "JSON-Schema-Test-Suite/tests/draft4" main :: IO () @@ -36,22 +36,20 @@ res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc) let failures = case res of Right () -> mempty - Left (D4.HVData a) -> N.toList a - other -> error ("Local.validate error: " + Left (D4.HVData a) -> NE.toList (D4._invalidFailures a) + other -> panic ("Local.validate error: " <> show other) - traverse_ (checkPointer (_scData sc)) failures assertResult sc failures validateExample :: JT.Schema -> SchemaTestCase -> Expectation validateExample s sc = do res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing) case res of - Left e -> error ("Remote.validateExample error: " <> show e) + Left e -> panic ("Remote.validateExample error: " <> show e) Right schemaMap -> do let failures = AlternateSchema.validate - (ReferencedSchemas s schemaMap) + (ReferencedSchemas s (_unURISchemaMap schemaMap)) Nothing s (_scData sc) - traverse_ (checkPointer (_scData sc)) failures assertResult sc failures serve :: IO () diff --git a/test/Shared.hs b/test/Shared.hs --- a/test/Shared.hs +++ b/test/Shared.hs @@ -1,29 +1,19 @@ -{-# LANGUAGE DeriveGeneric #-} module Shared where -import Control.Applicative -import Control.Monad +import Protolude + +import Control.Monad (fail) import Data.Aeson -import qualified Data.Aeson.Pointer as AP import Data.Aeson.TH -import qualified Data.ByteString.Lazy as LBS -import Data.Char (toLower) -import qualified Data.HashMap.Strict as HM -import Data.List (isInfixOf, stripPrefix) -import Data.Maybe -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import Data.Traversable -import qualified Data.Vector as V -import GHC.Generics -import qualified System.Directory as SD -import System.FilePath (()) +import qualified Data.ByteString.Lazy as LBS +import Data.Char (toLower) +import Data.List (stripPrefix, unlines) +import qualified Data.Text as T +import qualified System.Directory as SD +import System.FilePath (()) import Test.Hspec -import qualified Data.JsonSchema.Draft4 as D4 - -- Recursively return the contents of a directory -- (or return itself if given a file as an argument). -- @@ -47,35 +37,14 @@ fs <- fmap (path ) <$> SD.listDirectory path concat <$> traverse listFilesFullPath fs -checkPointer :: Value -> D4.Failure -> Expectation -checkPointer v failure = - case AP.resolve (D4._failureOffendingPointer failure) v of - Left e -> error ("Couldn't resolve pointer: " <> show e) - Right a -> assertContains a (D4._failureOffendingData failure) - where - -- Some validators, such as 'additionalItems', only return a subset - -- of the data incated by their '_failureOffendingPointer'. - -- See the comments on 'Data.Validator.Failure.Failure' for more info. - assertContains :: Value -> Value -> Expectation - assertContains x y - | x == y = pure () - | otherwise = - case (x,y) of - (Array xs, Array ys) -> - V.toList ys `shouldSatisfy` (`isInfixOf` V.toList xs) - (Object xhm, Object yhm) -> - HM.toList yhm `shouldSatisfy` (`isInfixOf` HM.toList xhm) - _ -> expectationFailure - "Pointer resolution incorrect: result mismatch" - -isHTTPTest :: String -> Bool +isHTTPTest :: FilePath -> Bool isHTTPTest file = (file == "definitions.json") || (file == "ref.json") || (file == "refRemote.json") -- | We may never support the @"format"@ keywords, and -- are currently failing the zeroTerminatedFloats test. -skipOptional :: String -> Bool +skipOptional :: FilePath -> Bool skipOptional file = (file == "optional/format.json") || (file == "optional/zeroTerminatedFloats.json") @@ -104,9 +73,9 @@ { fieldLabelModifier = fmap toLower . drop 3 } readSchemaTests - :: String + :: FilePath -- ^ The path to a directory. - -> (String -> Bool) + -> (FilePath -> Bool) -- ^ A function to decide what we're interested in within that directory. -> IO [SchemaTest] readSchemaTests dir filterFunc = do @@ -114,7 +83,7 @@ concat <$> traverse fileToCases files where -- Each file contains an array of SchemaTests, not just one. - fileToCases :: String -> IO [SchemaTest] + fileToCases :: FilePath -> IO [SchemaTest] fileToCases name = do let fullPath = dir name jsonBS <- LBS.readFile fullPath @@ -122,7 +91,7 @@ Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e Right schemaTests -> pure $ prependFileName name <$> schemaTests - prependFileName :: String -> SchemaTest -> SchemaTest + prependFileName :: FilePath -> SchemaTest -> SchemaTest prependFileName fileName s = s { _stDescription = T.pack fileName <> ": " <> _stDescription s } @@ -138,15 +107,15 @@ where schema :: schema schema = case fromJSON (_stSchema st) of - Error e -> error ("Couldn't parse schema: " <> show e) + Error e -> panic ("Couldn't parse schema: " <> show e) Success a -> a -assertResult :: SchemaTestCase -> [D4.Failure] -> Expectation +assertResult :: Show err => SchemaTestCase -> [err] -> Expectation assertResult sc failures | _scValid sc = assertValid sc failures | otherwise = assertInvalid sc failures -assertValid :: SchemaTestCase -> [D4.Failure] -> Expectation +assertValid :: Show err => SchemaTestCase -> [err] -> Expectation assertValid _ [] = pure () assertValid sc failures = expectationFailure $ unlines @@ -156,7 +125,7 @@ , " Validation failures: " <> show failures ] -assertInvalid :: SchemaTestCase -> [D4.Failure] -> Expectation +assertInvalid :: SchemaTestCase -> [err] -> Expectation assertInvalid sc [] = expectationFailure $ unlines [ " Validated invalid data"