diff --git a/JSON-Schema-Test-Suite/remotes/name.json b/JSON-Schema-Test-Suite/remotes/name.json new file mode 100644 --- /dev/null +++ b/JSON-Schema-Test-Suite/remotes/name.json @@ -0,0 +1,11 @@ +{ + "definitions": { + "orNull": { + "anyOf": [ + {"type": "null"}, + {"$ref": "#"} + ] + } + }, + "type": "string" +} diff --git a/JSON-Schema-Test-Suite/tests/draft4/additionalItems.json b/JSON-Schema-Test-Suite/tests/draft4/additionalItems.json --- a/JSON-Schema-Test-Suite/tests/draft4/additionalItems.json +++ b/JSON-Schema-Test-Suite/tests/draft4/additionalItems.json @@ -40,7 +40,12 @@ }, "tests": [ { - "description": "no additional items present", + "description": "fewer number of items present", + "data": [ 1, 2 ], + "valid": true + }, + { + "description": "equal number of items present", "data": [ 1, 2, 3 ], "valid": true }, diff --git a/JSON-Schema-Test-Suite/tests/draft4/items.json b/JSON-Schema-Test-Suite/tests/draft4/items.json --- a/JSON-Schema-Test-Suite/tests/draft4/items.json +++ b/JSON-Schema-Test-Suite/tests/draft4/items.json @@ -19,6 +19,14 @@ "description": "ignores non-arrays", "data": {"foo" : "bar"}, "valid": true + }, + { + "description": "JavaScript pseudo-array is valid", + "data": { + "0": "invalid", + "length": 1 + }, + "valid": true } ] }, @@ -40,6 +48,30 @@ "description": "wrong types", "data": [ "foo", 1 ], "valid": false + }, + { + "description": "incomplete array of items", + "data": [ 1 ], + "valid": true + }, + { + "description": "array with additional items", + "data": [ 1, "foo", true ], + "valid": true + }, + { + "description": "empty array", + "data": [ ], + "valid": true + }, + { + "description": "JavaScript pseudo-array is valid", + "data": { + "0": "invalid", + "1": "valid", + "length": 2 + }, + "valid": true } ] } diff --git a/JSON-Schema-Test-Suite/tests/draft4/maximum.json b/JSON-Schema-Test-Suite/tests/draft4/maximum.json --- a/JSON-Schema-Test-Suite/tests/draft4/maximum.json +++ b/JSON-Schema-Test-Suite/tests/draft4/maximum.json @@ -9,6 +9,11 @@ "valid": true }, { + "description": "boundary point is valid", + "data": 3.0, + "valid": true + }, + { "description": "above the maximum is invalid", "data": 3.5, "valid": false diff --git a/JSON-Schema-Test-Suite/tests/draft4/minimum.json b/JSON-Schema-Test-Suite/tests/draft4/minimum.json --- a/JSON-Schema-Test-Suite/tests/draft4/minimum.json +++ b/JSON-Schema-Test-Suite/tests/draft4/minimum.json @@ -9,6 +9,11 @@ "valid": true }, { + "description": "boundary point is valid", + "data": 1.1, + "valid": true + }, + { "description": "below the minimum is invalid", "data": 0.6, "valid": false diff --git a/JSON-Schema-Test-Suite/tests/draft4/optional/ecmascript-regex.json b/JSON-Schema-Test-Suite/tests/draft4/optional/ecmascript-regex.json new file mode 100644 --- /dev/null +++ b/JSON-Schema-Test-Suite/tests/draft4/optional/ecmascript-regex.json @@ -0,0 +1,13 @@ +[ + { + "description": "ECMA 262 regex non-compliance", + "schema": { "format": "regex" }, + "tests": [ + { + "description": "ECMA 262 has no support for \\Z anchor from .NET", + "data": "^\\S(|(.|\\n)*\\S)\\Z", + "valid": false + } + ] + } +] diff --git a/JSON-Schema-Test-Suite/tests/draft4/optional/format.json b/JSON-Schema-Test-Suite/tests/draft4/optional/format.json --- a/JSON-Schema-Test-Suite/tests/draft4/optional/format.json +++ b/JSON-Schema-Test-Suite/tests/draft4/optional/format.json @@ -30,9 +30,9 @@ "valid": true }, { - "description": "a valid protocol-relative URI", + "description": "an invalid protocol-relative URI Reference", "data": "//foo.bar/?baz=qux#quux", - "valid": true + "valid": false }, { "description": "an invalid URI", diff --git a/JSON-Schema-Test-Suite/tests/draft4/ref.json b/JSON-Schema-Test-Suite/tests/draft4/ref.json --- a/JSON-Schema-Test-Suite/tests/draft4/ref.json +++ b/JSON-Schema-Test-Suite/tests/draft4/ref.json @@ -141,6 +141,39 @@ ] }, { + "description": "ref overrides any sibling keywords", + "schema": { + "definitions": { + "reffed": { + "type": "array" + } + }, + "properties": { + "foo": { + "$ref": "#/definitions/reffed", + "maxItems": 2 + } + } + }, + "tests": [ + { + "description": "ref valid", + "data": { "foo": [] }, + "valid": true + }, + { + "description": "ref valid, maxItems ignored", + "data": { "foo": [ 1, 2, 3] }, + "valid": true + }, + { + "description": "ref invalid", + "data": { "foo": "string" }, + "valid": false + } + ] + }, + { "description": "remote ref, containing refs itself", "schema": {"$ref": "http://json-schema.org/draft-04/schema#"}, "tests": [ @@ -152,6 +185,112 @@ { "description": "remote ref invalid", "data": {"minLength": -1}, + "valid": false + } + ] + }, + { + "description": "property named $ref that is not a reference", + "schema": { + "properties": { + "$ref": {"type": "string"} + } + }, + "tests": [ + { + "description": "property named $ref valid", + "data": {"$ref": "a"}, + "valid": true + }, + { + "description": "property named $ref invalid", + "data": {"$ref": 2}, + "valid": false + } + ] + }, + { + "description": "Recursive references between schemas", + "schema": { + "description": "tree of nodes", + "type": "object", + "properties": { + "meta": {"type": "string"}, + "nodes": { + "type": "array", + "items": {"$ref": "#/definitions/node"} + } + }, + "required": ["meta", "nodes"], + "definitions": { + "node": { + "description": "node", + "type": "object", + "properties": { + "value": {"type": "number"}, + "subtree": {"$ref": "#"} + }, + "required": ["value"] + } + } + }, + "tests": [ + { + "description": "valid tree", + "data": { + "meta": "root", + "nodes": [ + { + "value": 1, + "subtree": { + "meta": "child", + "nodes": [ + {"value": 1.1}, + {"value": 1.2} + ] + } + }, + { + "value": 2, + "subtree": { + "meta": "child", + "nodes": [ + {"value": 2.1}, + {"value": 2.2} + ] + } + } + ] + }, + "valid": true + }, + { + "description": "invalid tree", + "data": { + "meta": "root", + "nodes": [ + { + "value": 1, + "subtree": { + "meta": "child", + "nodes": [ + {"value": "string is invalid"}, + {"value": 1.2} + ] + } + }, + { + "value": 2, + "subtree": { + "meta": "child", + "nodes": [ + {"value": 2.1}, + {"value": 2.2} + ] + } + } + ] + }, "valid": false } ] diff --git a/JSON-Schema-Test-Suite/tests/draft4/refRemote.json b/JSON-Schema-Test-Suite/tests/draft4/refRemote.json --- a/JSON-Schema-Test-Suite/tests/draft4/refRemote.json +++ b/JSON-Schema-Test-Suite/tests/draft4/refRemote.json @@ -50,7 +50,7 @@ ] }, { - "description": "change resolution scope", + "description": "base URI change", "schema": { "id": "http://localhost:1234/", "items": { @@ -60,13 +60,110 @@ }, "tests": [ { - "description": "changed scope ref valid", + "description": "base URI change ref valid", "data": [[1]], "valid": true }, { - "description": "changed scope ref invalid", + "description": "base URI change ref invalid", "data": [["a"]], + "valid": false + } + ] + }, + { + "description": "base URI change - change folder", + "schema": { + "id": "http://localhost:1234/scope_change_defs1.json", + "type" : "object", + "properties": { + "list": {"$ref": "#/definitions/baz"} + }, + "definitions": { + "baz": { + "id": "folder/", + "type": "array", + "items": {"$ref": "folderInteger.json"} + } + } + }, + "tests": [ + { + "description": "number is valid", + "data": {"list": [1]}, + "valid": true + }, + { + "description": "string is invalid", + "data": {"list": ["a"]}, + "valid": false + } + ] + }, + { + "description": "base URI change - change folder in subschema", + "schema": { + "id": "http://localhost:1234/scope_change_defs2.json", + "type" : "object", + "properties": { + "list": {"$ref": "#/definitions/baz/definitions/bar"} + }, + "definitions": { + "baz": { + "id": "folder/", + "definitions": { + "bar": { + "type": "array", + "items": {"$ref": "folderInteger.json"} + } + } + } + } + }, + "tests": [ + { + "description": "number is valid", + "data": {"list": [1]}, + "valid": true + }, + { + "description": "string is invalid", + "data": {"list": ["a"]}, + "valid": false + } + ] + }, + { + "description": "root ref in remote ref", + "schema": { + "id": "http://localhost:1234/object", + "type": "object", + "properties": { + "name": {"$ref": "name.json#/definitions/orNull"} + } + }, + "tests": [ + { + "description": "string is valid", + "data": { + "name": "foo" + }, + "valid": true + }, + { + "description": "null is valid", + "data": { + "name": null + }, + "valid": true + }, + { + "description": "object is invalid", + "data": { + "name": { + "name": null + } + }, "valid": false } ] diff --git a/JSON-Schema-Test-Suite/tests/draft4/required.json b/JSON-Schema-Test-Suite/tests/draft4/required.json --- a/JSON-Schema-Test-Suite/tests/draft4/required.json +++ b/JSON-Schema-Test-Suite/tests/draft4/required.json @@ -18,6 +18,11 @@ "description": "non-present required property is invalid", "data": {"bar": 1}, "valid": false + }, + { + "description": "ignores non-objects", + "data": 12, + "valid": true } ] }, diff --git a/JSON-Schema-Test-Suite/tests/draft4/type.json b/JSON-Schema-Test-Suite/tests/draft4/type.json --- a/JSON-Schema-Test-Suite/tests/draft4/type.json +++ b/JSON-Schema-Test-Suite/tests/draft4/type.json @@ -19,6 +19,11 @@ "valid": false }, { + "description": "a string is still not an integer, even if it looks like one", + "data": "1", + "valid": false + }, + { "description": "an object is not an integer", "data": {}, "valid": false @@ -60,6 +65,11 @@ "valid": false }, { + "description": "a string is still not a number, even if it looks like one", + "data": "1", + "valid": false + }, + { "description": "an object is not a number", "data": {}, "valid": false @@ -98,6 +108,11 @@ { "description": "a string is a string", "data": "foo", + "valid": true + }, + { + "description": "a string is still a string, even if it looks like a number", + "data": "1", "valid": true }, { diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,61 +1,25 @@ -![hjsonschema logo](./logo.jpg) +# DEPRECATION NOTICE -A Haskell implementation of the current [JSON Schema](http://json-schema.org/) specification (Draft 4). +`hjsonschema` was an attempt to build a very modular JSON Schema library. Validators have [a concrete type](src/JSONSchema/Validator/Types.hs) and can be mixed and matched into new [Specs](src/JSONSchema/Types.hs). -[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema) +However this flexibility came at the price of complicating the code. I don't think it was the right tradeoff, especially since situations where you'd want to change what validators make up a `Spec` at runtime seem rare. -Requires [pcre](http://www.pcre.org/) (`pkgs.pcre` in Nixpkgs). +Also, there are many parts of JSON Schema that `hjsonschema` doesn't implement properly (as you can see from the issue tracker). I'm hoping that a new JSON Schema library will come along that handles these correctly. In the meantime I'm happy to merge working fixes into here. -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. +# Links +[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema) + # Example See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Simple.hs). -# Tests - -Run all tests: - -`stack test` - -Run only local tests: - -`stack test hjsonschema:local` - -Run remote tests (makes GETs to json-schema.org, also temporarily starts an HTTP server on port 1234): - -`stack test hjsonschema:remote` - -# Details - -## Goals - -+ Be a correct and fast implementation of the spec. - -+ Be a useful reference for implementers in other languages. Haskell's high level nature, expressive type system and referential transparency suit this purpose well. - -## Good Parts - -+ Passes all the required tests in the [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite). - -+ Very modular, which should make it easy to support future versions of the specification. - -## Bad Parts - -+ Uses the [pcre-heavy](https://hackage.haskell.org/package/pcre-heavy) regular expression library for the "pattern" validator. It should use a library based on the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires. - -+ Currently doesn't support the optional `"format"` validators. - -## Notes - -+ `JSON-Schema-Test-Suite` is vendored from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite). - -+ `src/draft4.json` is from commit # f3d5aeb5ffbe9d9a5a0ceb761dc47c7c4c2efa68 [here](https://github.com/json-schema/json-schema). +# System dependencies -## Credits ++ Requires [pcre](http://www.pcre.org/) (`pkgs.pcre` in Nixpkgs). -[TJ Weigel](http://tjweigel.com/) created the logo. +## Vendoring -[Tim Baumann](https://github.com/timjb) wrote [aeson-schema](https://hackage.haskell.org/package/aeson-schema), on which hjsonschema's test code and its implementation of `SchemaGraph` were based. ++ `JSON-Schema-Test-Suite` is vendored from commit # c1b12bf699f29a04b4286711c6e3bbfba66f21e5 [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite). -[Julian Berman](https://github.com/Julian) maintains the fantastic [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite). ++ `src/draft4.json` is from commit # c1b12bf699f29a04b4286711c6e3bbfba66f21e5 [here](https://github.com/json-schema/json-schema). The [root ref in remote ref](./JSON-Schema-Test-Suite/tests/draft4/refRemote.json) test has been modified to fix [#175](https://github.com/json-schema-org/JSON-Schema-Test-Suite/issues/175). diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,213 @@ +# 1.10.0 + ++ String match fixes (thanks @sol !). + +# 1.8.0 + ++ Add GHC 8.4 support (thanks @4e6 !). ++ Drop GHC 7.10 support. ++ Fix JSON Pointer resolution error. + +# 1.8.0 + ++ Allow HTTPS references (thanks @creichert!). ++ Use `safe-exceptions` to eliminate the risk of catching asynchronous exceptions. + +# 1.7.2 + ++ Remove upper bounds. + +# 1.7.1 + ++ Bump http-types. + +# 1.7.0 + ++ Test with GHC 8.2. Drop GHC 7.8. ++ Rework `allUniqueValues` related utility functions. + +# 1.6.3 + ++ Bump hjsonpointer and QuickCheck. + +# 1.6.2 + ++ Bump aeson. + +# 1.6.1 + ++ Fix Haddocks. + +# 1.6.0 + ++ Fix defect where validators alongside "$ref" weren't ignored. + ++ Fix defect where local references would fail if an "id" key had set resolution scope to start from a different document. + ++ Vendor latest tests. + ++ Remove `ReferencedSchemas`. + ++ Create `Scope` to hold information that changes during validation. + ++ Use a sum type for "type" values. Thanks to Philip Weaver (GitHub @pheaver). + +# 1.5.0.1 + ++ Raise test dep upper bounds. + +# 1.5.0.0 + ++ Report details of `"required"` validator failure. ++ Bump `directory`. + +# 1.4.0.0 + ++ Rename `Data.JsonSchema.*` modules to `JSONSchema.*`. ++ Rename `Data.Validator.*` modules to `JSONSchema.Validator.*`. + +# 1.3.0.1 + ++ Bump `vector`. + +# 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. + +# 1.2.0.1 + ++ Switch to hspec for tests. + +# 1.2.0.0 + ++ Return `AdditionalPropertiesObject` error correctly (was mistakenly returning `AdditionalItemsObject` instead. ++ Don't silence errors resulting from subschemas of "anyOf" or "oneOf". + +# 1.1.0.1 + ++ Bump `aeson` and `hjsonpointer`. + +# 1.1.0.0 + ++ 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. + +## 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. + +## Fundamental Changes: + ++ Make `Fail` (previously `Failure`) an instance of `Functor`. ++ Add a `Validator` data type which is an instance of `Profunctor`. ++ Add a `Spec` data type for collections of `Validators`. + +## General: + ++ Switch from 2 to 4 space indentation. ++ Update the vendored JSON Schema Test Suite. + +# 0.10.0.3 + ++ Bump http-client. + +# 0.10.0.2 + ++ Enable GHC 8. + +# 0.10.0.1 + ++ Fix .cabal file. + +# 0.10 + ++ Rewrite fetching internals. ++ Fix reference resolution defects, add more tests. ++ Switch to a Perl style regex library, which is closer to ECMAScript regexes than the previous Posix style one. ++ Add one-step validation functions ('fetchFilesystemAndValidate' and 'fetchHTTPAndValidate'). ++ Alias the validation failure type exported by 'Data.JsonSchema.Draft4' to +'Invalid', change its field names. + +# 0.9 + ++ Partial rewrite. The API of the library has changed, see the examples +folder for how to use the new one. + ++ Users of the library can now write schemas in Haskell as well as JSON. + +# 0.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. "#"). ++ Change the order of the last two arguments to fetchReferencedSchemas. + +# 0.7.1 + ++ Support GHC 7.8 again. + +# 0.7 + +Change error type from Text to ValidationFailure. + +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. + +# 0.6 + +Break the API so the library doesn't induce boolean blindness. + +Change validate + was: Schema -> Value -> Vector ValErr + now: Schema -> Value -> Either (Vector ValErr) Value + +Change Schema + was: type Schema = Vector Validator + now: newtype Schema = Schema { _unSchema :: [Validator] } + +# 0.5.3 + ++ Switch from http-conduit to http-client. + +# 0.5.2 + ++ Add convenience function for validating and compiling draft 4 schemas simultaneously. + +# 0.5.1 + ++ Switch from wreq to http-conduit; drop lens dependency. + +# 0.5 + ++ Start changelog. ++ Rename Utils.hs to Helpers.hs. ++ Move all non-ValidatorGen functions in Validators.hs to Helpers.hs. ++ Various touchups. diff --git a/changelog.txt b/changelog.txt deleted file mode 100644 --- a/changelog.txt +++ /dev/null @@ -1,146 +0,0 @@ -# 1.2.0.2 - -+ Bump hspec. - -# 1.2.0.1 - -+ Switch to hspec for tests. - -# 1.2.0.0 - -+ Return `AdditionalPropertiesObject` error correctly (was mistakenly -returning `AdditionalItemsObject` instead. -+ Don't silence errors resulting from subschemas of "anyOf" or "oneOf". - -# 1.1.0.1 - -+ Bump `aeson` and `hjsonpointer`. - -# 1.1.0.0 - -+ 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. - -## 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. - -## Fundamental Changes: - -+ Make `Fail` (previously `Failure`) an instance of `Functor`. -+ Add a `Validator` data type which is an instance of `Profunctor`. -+ Add a `Spec` data type for collections of `Validators`. - -## General: - -+ Switch from 2 to 4 space indentation. -+ Update the vendored JSON Schema Test Suite. - -# 0.10.0.3 - -+ Bump http-client. - -# 0.10.0.2 - -+ Enable GHC 8. - -# 0.10.0.1 - -+ Fix .cabal file. - -# 0.10 - -+ Rewrite fetching internals. -+ Fix reference resolution defects, add more tests. -+ Switch to a Perl style regex library, which is closer to ECMAScript regexes -than the previous Posix style one. -+ Add one-step validation functions ('fetchFilesystemAndValidate' and 'fetchHTTPAndValidate'). -+ Alias the validation failure type exported by 'Data.JsonSchema.Draft4' to -'Invalid', change its field names. - -# 0.9 - -+ Partial rewrite. The API of the library has changed, see the examples -folder for how to use the new one. - -+ Users of the library can now write schemas in Haskell as well as JSON. - -# 0.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. "#"). -+ Change the order of the last two arguments to fetchReferencedSchemas. - -# 0.7.1 - -+ Support GHC 7.8 again. - -# 0.7 - -Change error type from Text to ValidationFailure. - -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. - -# 0.6 - -Break the API so the library doesn't induce boolean blindness. - -Change validate - was: Schema -> Value -> Vector ValErr - now: Schema -> Value -> Either (Vector ValErr) Value - -Change Schema - was: type Schema = Vector Validator - now: newtype Schema = Schema { _unSchema :: [Validator] } - -# 0.5.3 - -+ Switch from http-conduit to http-client. - -# 0.5.2 - -+ Add convenience function for validating and compiling draft 4 schemas -simultaneously. - -# 0.5.1 - -+ Switch from wreq to http-conduit; drop lens dependency. - -# 0.5 - -+ Start changelog. -+ Rename Utils.hs to Helpers.hs. -+ Move all non-ValidatorGen functions in Validators.hs to Helpers.hs. -+ Various touchups. diff --git a/examples/AlternateSchema.hs b/examples/AlternateSchema.hs --- a/examples/AlternateSchema.hs +++ b/examples/AlternateSchema.hs @@ -1,39 +1,29 @@ -- | An implementation of JSON Schema Draft 4 based on 'HashMap Text Value' --- instead of a custom record type like 'Data.JsonSchema.Draft4'. +-- instead of a custom record type like 'JSONSchema.Draft4'. -- -- If you're writing code for a new schema specification you probably want --- to copy this module instead of the 'Data.JsonSchema.Draft4'. While it's +-- to copy this module instead of the '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(..), decodeStrict) +import qualified Data.Aeson as AE +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import Data.Profunctor (Profunctor(..)) +import JSONSchema.Draft4 (ValidatorFailure(..), metaSchemaBytes) +import JSONSchema.Fetch (SchemaWithURI(..), URISchemaMap(..)) +import qualified JSONSchema.Fetch as FE +import JSONSchema.Types (Schema(..), Spec(..)) +import qualified JSONSchema.Types as JT +import qualified JSONSchema.Validator.Draft4 as D4 +import JSONSchema.Validator.Reference (BaseURI(..), Scope(..), + updateResolutionScope) + -------------------------------------------------- -- * Basic fetching tools -------------------------------------------------- @@ -44,117 +34,167 @@ 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 +-- | An implementation of 'JT.embedded'. embedded :: Schema -> ([Schema], [Schema]) -embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s +embedded s = + JT.embedded (d4Spec mempty mempty (Scope s Nothing (BaseURI Nothing))) s -------------------------------------------------- -- * Main API -------------------------------------------------- validate - :: ReferencedSchemas Schema - -> Maybe Text - -> Schema + :: URISchemaMap Schema + -> SchemaWithURI Schema -> Value - -> [Failure] -validate rs = continueValidating rs (AN.VisitedSchemas [(Nothing, Nothing)]) + -> [ValidatorFailure] +validate schemaMap sw = + JT.validate (d4Spec schemaMap visited scope) (_swSchema sw) + where + visited :: D4.VisitedSchemas + visited = D4.VisitedSchemas [(Nothing, Nothing)] --- A schema for schemas themselves, using @src/draft4.json@ which is loaded + schemaId :: Maybe Text + schemaId = FE._fiId draft4FetchInfo (_swSchema sw) + + scope :: Scope Schema + scope = Scope + { _topLevelDocument = _swSchema sw + , _documentURI = _swURI sw + , _currentBaseURI = updateResolutionScope (BaseURI (_swURI sw)) + schemaId + } + +-- | A schema for schemas themselves. Uses @src/draft4.json@ which is loaded -- at compile time. metaSchema :: Schema metaSchema = - fromMaybe (error "Schema decode failed (this should never happen)") - . decode - . LBS.fromStrict + fromMaybe (panic "Schema decode failed (this should never happen)") + . decodeStrict $ metaSchemaBytes -checkSchema :: Schema -> [Failure] -checkSchema = validate referenced Nothing metaSchema . Object . _unSchema +checkSchema :: Schema -> [ValidatorFailure] +checkSchema = validate schemaMap (SchemaWithURI metaSchema Nothing) + . Object + . _unSchema where - referenced :: ReferencedSchemas Schema - referenced = ReferencedSchemas - metaSchema - (HM.singleton "http://json-schema.org/draft-04/schema" - metaSchema) + schemaMap :: URISchemaMap Schema + schemaMap = + URISchemaMap (HM.singleton "http://json-schema.org/draft-04/schema" + metaSchema) -------------------------------------------------- -- * Spec -------------------------------------------------- -continueValidating - :: ReferencedSchemas Schema - -> AN.VisitedSchemas - -> Maybe Text +validateSubschema + :: URISchemaMap Schema + -> D4.VisitedSchemas + -> Scope Schema -> Schema -> Value - -> [Failure] -continueValidating referenced visited mURI sc = - JT.validate (d4Spec referenced visited newScope) sc + -> [ValidatorFailure] +validateSubschema schemaMap visited scope schema = + JT.validate (d4Spec schemaMap visited newScope) schema where schemaId :: Maybe Text - schemaId = case HM.lookup "id" (_unSchema sc) of - Just (String t) -> Just t - _ -> Nothing + schemaId = FE._fiId draft4FetchInfo schema - newScope :: Maybe Text - newScope = updateResolutionScope mURI schemaId + newScope :: Scope Schema + newScope = scope + { _currentBaseURI = updateResolutionScope (_currentBaseURI scope) + schemaId + } d4Spec - :: ReferencedSchemas Schema - -> AN.VisitedSchemas - -> Maybe Text - -> Spec Schema ValidatorChain -d4Spec referenced visited scope = - Spec - [ dimap f (const MultipleOf) D4.multipleOf - , dimap f maxE D4.maximumVal - , dimap f minE D4.minimumVal + :: URISchemaMap Schema + -> D4.VisitedSchemas + -> Scope Schema + -> Spec Schema ValidatorFailure + -- ^ Here we reuses 'ValidatorFailure' from + -- 'JSONSchema.Draft4.Failure'. If your validators have different + -- failure possibilities you'll need to create your own validator + -- failure type. +d4Spec schemaMap visited scope = + Spec $ + [ dimap + f + FailureRef + (D4.refValidator (FE.getReference schemaMap) updateScope + valRef visited scope) + ] - , dimap f (const MaxLength) D4.maxLength - , dimap f (const MinLength) D4.minLength - , dimap f (const PatternValidator) D4.patternVal + <> fmap (lmap disableIfRefPresent) + [ dimap f FailureMultipleOf D4.multipleOfValidator + , dimap f FailureMaximum D4.maximumValidator + , dimap f FailureMinimum D4.minimumValidator - , 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 FailureMaxLength D4.maxLengthValidator + , dimap f FailureMinLength D4.minLengthValidator + , dimap f FailurePattern D4.patternValidator - , 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 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) + , lmap f D4.definitionsEmbedded - , 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 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 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 - f (Schema a) = case AE.fromJSON (Object a) of - AE.Error _ -> Nothing - AE.Success b -> Just b + f (Schema a) = + case AE.fromJSON (Object a) of + AE.Error _ -> Nothing + AE.Success b -> Just b - -- 'Maybe Text' is the URI the refernced schema is fetch from, - -- this probably needs a 'newtype' wrapper. - refVal :: AN.VisitedSchemas -> Maybe Text -> Schema -> Value -> [Failure] - refVal = continueValidating referenced + disableIfRefPresent :: Schema -> Schema + disableIfRefPresent schema = + case FE._fiRef draft4FetchInfo schema of + Nothing -> schema + Just _ -> Schema mempty - descend :: Schema -> Value -> [Failure] - descend = continueValidating referenced mempty scope + updateScope :: BaseURI -> Schema -> BaseURI + updateScope uri schema = + updateResolutionScope uri (FE._fiId draft4FetchInfo schema) - lateral :: Schema -> Value -> [Failure] - lateral = continueValidating referenced visited scope + valRef + :: D4.VisitedSchemas + -> Scope Schema + -> Schema + -> Value + -> [ValidatorFailure] + valRef vis sc = JT.validate (d4Spec schemaMap vis sc) + + descend :: Schema -> Value -> [ValidatorFailure] + descend = validateSubschema schemaMap mempty scope + + lateral :: Schema -> Value -> [ValidatorFailure] + lateral = validateSubschema schemaMap 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,37 +1,37 @@ --- | Demonstrate 'D4.fetchFilesystemAndValidate'. --- --- To fetch schemas using HTTP instead of from the filesystem use --- 'D4.fetchHTTPAndValidate'. - module Simple where -import Data.Aeson (Value(..), decode, toJSON) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) +import Protolude -import qualified Data.JsonSchema.Draft4 as D4 +import Data.Aeson (Value(..), decodeStrict, toJSON) +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) +import qualified 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 <- BS.readFile "./examples/json/unique.json" + let schema = fromMaybe (panic "Invalid schema JSON.") (decodeStrict 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,48 @@ +-- | 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 JSONSchema.Draft4 as D4 +import qualified JSONSchema.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.10.0 synopsis: JSON Schema library homepage: https://github.com/seagreen/hjsonschema license: MIT @@ -9,8 +9,10 @@ category: Data build-type: Simple cabal-version: >=1.10 +-- Rerun multi-ghc-travis (executable make-travis-yml-2) after changing: +Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 extra-source-files: - changelog.txt + changelog.md JSON-Schema-Test-Suite/remotes/*.json JSON-Schema-Test-Suite/remotes/folder/*.json JSON-Schema-Test-Suite/tests/draft4/*.json @@ -26,58 +28,104 @@ src default-language: Haskell2010 default-extensions: + DeriveFunctor + DeriveGeneric + GeneralizedNewtypeDeriving NoImplicitPrelude OverloadedStrings ScopedTypeVariables if impl(ghc >= 8) default-extensions: StrictData - other-extensions: - DeriveFunctor - GeneralizedNewtypeDeriving - TemplateHaskell ghc-options: -Wall exposed-modules: - Data.JsonSchema.Draft4 - , Data.JsonSchema.Draft4.Failure - , Data.JsonSchema.Draft4.Schema - , Data.JsonSchema.Draft4.Spec - , Data.JsonSchema.Fetch - , Data.JsonSchema.Types - , Data.Validator.Draft4 - , Data.Validator.Draft4.Any - , Data.Validator.Draft4.Array - , Data.Validator.Draft4.Number - , Data.Validator.Draft4.Object - , Data.Validator.Draft4.String - , Data.Validator.Failure - , Data.Validator.Reference - , Data.Validator.Types - , Data.Validator.Utils + JSONSchema.Draft4 + , JSONSchema.Draft4.Failure + , JSONSchema.Draft4.Schema + , JSONSchema.Draft4.Spec + , JSONSchema.Fetch + , JSONSchema.Types + , JSONSchema.Validator.Draft4 + , JSONSchema.Validator.Draft4.Any + , JSONSchema.Validator.Draft4.Array + , JSONSchema.Validator.Draft4.Number + , JSONSchema.Validator.Draft4.Object + , JSONSchema.Validator.Draft4.String + , JSONSchema.Validator.Reference + , JSONSchema.Validator.Types + , JSONSchema.Validator.Utils other-modules: - Data.Validator.Draft4.Object.Properties + JSONSchema.Validator.Draft4.Object.Properties , Import build-depends: - base >= 4.7 && < 4.10 + base >= 4.7 && < 5 -- 0.11 is for `.:!`: - , aeson >= 0.11 && < 1.1 - , 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 + , aeson >= 0.11 + , bytestring >= 0.10 + , containers >= 0.5 + , file-embed >= 0.0.8 + , filepath >= 1.3 + , hashable >= 1.2 + , hjsonpointer >= 1.1 -- 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 - , QuickCheck >= 2.8 && < 2.10 - , scientific >= 0.3 && < 0.4 - , semigroups >= 0.18 && < 0.19 - , unordered-containers >= 0.2 && < 0.3 - , text >= 1.1 && < 1.3 - , vector >= 0.10 && < 0.12 + , http-client >= 0.4.30 + , http-client-tls >= 0.3 + , http-types >= 0.8 + , pcre-heavy >= 1.0 + , profunctors >= 5.0 + , protolude >= 0.1.10 + , QuickCheck >= 2.8 + , safe-exceptions >= 0.1.6 + , scientific >= 0.3 + , unordered-containers >= 0.2 + , text >= 1.1 + , vector >= 0.10 +test-suite spec + hs-source-dirs: + test + src + main-is: Spec.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: + -Wall + default-extensions: + DeriveGeneric + NoImplicitPrelude + OverloadedStrings + ScopedTypeVariables + other-modules: + Import + JSONSchema.Validator.Draft4.String + + JSONSchema.Validator.Draft4.StringSpec + build-depends: + base >= 4.7 && < 5 + -- 0.11 is for `.:!`: + , aeson >= 0.11 + , bytestring >= 0.10 + , containers >= 0.5 + , file-embed >= 0.0.8 + , filepath >= 1.3 + , hashable >= 1.2 + , hjsonpointer >= 1.1 + -- 0.4.30 is for parseUrlThrow: + , http-client >= 0.4.30 + , http-client-tls >= 0.3 + , http-types >= 0.8 + , pcre-heavy >= 1.0 + , profunctors >= 5.0 + , protolude >= 0.1.10 + , QuickCheck >= 2.8 + , safe-exceptions >= 0.1.6 + , scientific >= 0.3 + , unordered-containers >= 0.2 + , text >= 1.1 + , vector >= 0.10 + + , hspec >= 2.2 + test-suite local hs-source-dirs: test @@ -89,6 +137,8 @@ -Wall -fno-warn-orphans default-extensions: + DeriveGeneric + NoImplicitPrelude OverloadedStrings ScopedTypeVariables other-modules: @@ -98,8 +148,8 @@ , Shared -- from ./examples: , AlternateSchema - , Full , Simple + , TwoStep build-depends: base , aeson @@ -108,15 +158,15 @@ , hjsonpointer , hjsonschema , profunctors - , semigroups + , protolude , text , QuickCheck , unordered-containers , vector -- directory-1.2.5 required for `listDirectory`: - , directory >= 1.2.5 && < 1.3 - , hspec >= 2.2 && < 2.4 + , directory >= 1.2.5 + , hspec >= 2.2 test-suite remote hs-source-dirs: @@ -129,6 +179,8 @@ -Wall -fno-warn-orphans default-extensions: + DeriveGeneric + NoImplicitPrelude OverloadedStrings ScopedTypeVariables other-modules: @@ -144,7 +196,7 @@ , hjsonpointer , hjsonschema , profunctors - , semigroups + , protolude , text , unordered-containers , vector @@ -153,7 +205,3 @@ , hspec , wai-app-static , warp - -source-repository head - type: git - location: git://github.com/seagreen/hjsonschema.git diff --git a/src/Data/JsonSchema/Draft4.hs b/src/Data/JsonSchema/Draft4.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Data.JsonSchema.Draft4 - ( -- * Draft 4 Schema - SchemaWithURI(..) - , Schema(..) - , SC.emptySchema - - -- * One-step validation (getting references over HTTP) - , fetchHTTPAndValidate - , HTTPValidationFailure(..) - , FE.HTTPFailure(..) - , InvalidSchema - - -- * One-step validation (getting references from the filesystem) - , fetchFilesystemAndValidate - , FilesystemValidationFailure(..) - , FE.FilesystemFailure(..) - - -- * Validation failure - , Invalid - , Failure - , FR.Fail(..) - , ValidatorChain(..) - - -- * Fetching tools - , ReferencedSchemas(..) - , referencesViaHTTP - , referencesViaFilesystem - - -- * Other Draft 4 things exported just in case - , metaSchema - , metaSchemaBytes - , schemaValidity - , referencesValidity - , checkSchema - , draft4FetchInfo - ) where - -import Import -import Prelude - -import Control.Arrow (first, left) -import qualified Data.ByteString as BS -import Data.FileEmbed (embedFile, - makeRelativeToProject) -import qualified Data.HashMap.Strict as HM -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) - -import Data.JsonSchema.Draft4.Failure (Failure, Invalid, - InvalidSchema, - ValidatorChain(..)) -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 - | HVData Invalid - deriving Show - --- | Fetch recursively referenced schemas over HTTP, check that both the --- original and referenced schemas are valid, and then validate data. -fetchHTTPAndValidate - :: SchemaWithURI Schema - -> Value - -> IO (Either HTTPValidationFailure ()) -fetchHTTPAndValidate sw v = do - res <- referencesViaHTTP sw - pure (g =<< f =<< left HVRequest res) - where - f :: FE.URISchemaMap Schema - -> Either HTTPValidationFailure (Value -> [Failure]) - 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) - -data FilesystemValidationFailure - = FVRead FE.FilesystemFailure - | FVSchema InvalidSchema - | 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. -fetchFilesystemAndValidate - :: SchemaWithURI Schema - -> Value - -> IO (Either FilesystemValidationFailure ()) -fetchFilesystemAndValidate sw v = do - res <- referencesViaFilesystem sw - pure (g =<< f =<< left FVRead res) - where - f :: FE.URISchemaMap Schema - -> Either FilesystemValidationFailure (Value -> [Failure]) - 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) - --- | An instance of 'Data.JsonSchema.Fetch.FetchInfo' specialized for --- JSON Schema Draft 4. -draft4FetchInfo :: FE.FetchInfo Schema -draft4FetchInfo = FE.FetchInfo Spec.embedded SC._schemaId SC._schemaRef - --- | Fetch the schemas recursively referenced by a starting schema over HTTP. -referencesViaHTTP - :: SchemaWithURI Schema - -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema)) -referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo - --- | Fetch the schemas recursively referenced by a starting schema from --- the filesystem. -referencesViaFilesystem - :: SchemaWithURI Schema - -> 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. --- --- Return a function to validate data. -checkSchema - :: FE.URISchemaMap Schema - -> SchemaWithURI Schema - -> Either InvalidSchema (Value -> [Failure]) -checkSchema sm sw = - case NE.nonEmpty failures of - Nothing -> Right (Spec.validate (ReferencedSchemas (_swSchema sw) sm) sw) - Just fs -> Left fs - where - failures :: [(Maybe Text, Failure)] - failures = ((\v -> (Nothing, v)) <$> schemaValidity (_swSchema sw)) - <> (first Just <$> referencesValidity sm) - -metaSchema :: Schema -metaSchema = - fromMaybe (error "Schema decode failed (this should never happen)") - . decodeStrict - $ metaSchemaBytes - -metaSchemaBytes :: BS.ByteString -metaSchemaBytes = - $(makeRelativeToProject "src/draft4.json" >>= embedFile) - --- | Check that a schema itself is valid --- (if so the returned list will be empty). -schemaValidity :: Schema -> [Failure] -schemaValidity = - Spec.validate referenced (SchemaWithURI metaSchema Nothing) . toJSON - where - referenced :: ReferencedSchemas Schema - referenced = ReferencedSchemas - metaSchema - (HM.singleton "http://json-schema.org/draft-04/schema" - 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 - where - f :: [(Text, Failure)] - -> Text - -> Schema - -> [(Text, Failure)] - f acc k v = ((\a -> (k,a)) <$> schemaValidity v) <> acc diff --git a/src/Data/JsonSchema/Draft4/Failure.hs b/src/Data/JsonSchema/Draft4/Failure.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4/Failure.hs +++ /dev/null @@ -1,123 +0,0 @@ - -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) - -type Invalid = NonEmpty Failure - -type Failure = FR.Fail ValidatorChain - --- | Distinguish all the different possible causes of failure for --- Draft 4 validation. -data ValidatorChain - = MultipleOf - | Maximum - | ExclusiveMaximum - | Minimum - | ExclusiveMinimum - - | MaxLength - | MinLength - | PatternValidator - - | MaxItems - | MinItems - | UniqueItems - | Items ValidatorChain - | AdditionalItemsBool - | AdditionalItemsObject ValidatorChain - - | MaxProperties - | MinProperties - | Required - | SchemaDependency ValidatorChain - | PropertyDependency - | Properties ValidatorChain - | PatternProperties ValidatorChain - | AdditionalPropertiesBool - | AdditionalPropertiesObject ValidatorChain - - | 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 - 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 diff --git a/src/Data/JsonSchema/Draft4/Schema.hs b/src/Data/JsonSchema/Draft4/Schema.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4/Schema.hs +++ /dev/null @@ -1,338 +0,0 @@ - -module Data.JsonSchema.Draft4.Schema where - -import Import -import Prelude - -import qualified Data.HashMap.Strict as HM -import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (fromJust, isJust) -import Data.Scientific - -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 Data.Validator.Utils - -data Schema = Schema - { _schemaVersion :: Maybe Text - , _schemaId :: Maybe Text - , _schemaRef :: Maybe Text - , _schemaDefinitions :: Maybe (HashMap Text Schema) - -- ^ A standardized location for embedding schemas - -- to be referenced from elsewhere in the document. - , _schemaOther :: HashMap Text Value - -- ^ Since the JSON document this schema was built from could - -- 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. - - , _schemaMultipleOf :: Maybe Scientific - , _schemaMaximum :: Maybe Scientific - , _schemaExclusiveMaximum :: Maybe Bool - , _schemaMinimum :: Maybe Scientific - , _schemaExclusiveMinimum :: Maybe Bool - - , _schemaMaxLength :: Maybe Int - , _schemaMinLength :: Maybe Int - , _schemaPattern :: Maybe Text - - , _schemaMaxItems :: Maybe Int - , _schemaMinItems :: Maybe Int - , _schemaUniqueItems :: Maybe Bool - , _schemaItems :: Maybe (AR.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) - - , _schemaMaxProperties :: Maybe Int - , _schemaMinProperties :: Maybe Int - , _schemaRequired :: Maybe OB.Required - , _schemaDependencies :: Maybe (HashMap Text (OB.Dependency Schema)) - , _schemaProperties :: Maybe (HashMap Text Schema) - , _schemaPatternProperties :: Maybe (HashMap Text Schema) - , _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema) - - , _schemaEnum :: Maybe AN.EnumVal - , _schemaType :: Maybe AN.TypeVal - , _schemaAllOf :: Maybe (NonEmpty Schema) - , _schemaAnyOf :: Maybe (NonEmpty Schema) - , _schemaOneOf :: Maybe (NonEmpty Schema) - , _schemaNot :: Maybe Schema - } deriving (Eq, Show) - -emptySchema :: Schema -emptySchema = Schema - { _schemaVersion = Nothing - , _schemaId = Nothing - , _schemaRef = Nothing - , _schemaDefinitions = Nothing - , _schemaOther = mempty - - , _schemaMultipleOf = Nothing - , _schemaMaximum = Nothing - , _schemaExclusiveMaximum = Nothing - , _schemaMinimum = Nothing - , _schemaExclusiveMinimum = Nothing - - , _schemaMaxLength = Nothing - , _schemaMinLength = Nothing - , _schemaPattern = Nothing - - , _schemaMaxItems = Nothing - , _schemaMinItems = Nothing - , _schemaUniqueItems = Nothing - , _schemaItems = Nothing - , _schemaAdditionalItems = Nothing - - , _schemaMaxProperties = Nothing - , _schemaMinProperties = Nothing - , _schemaRequired = Nothing - , _schemaDependencies = Nothing - , _schemaProperties = Nothing - , _schemaPatternProperties = Nothing - , _schemaAdditionalProperties = Nothing - - , _schemaEnum = Nothing - , _schemaType = Nothing - , _schemaAllOf = Nothing - , _schemaAnyOf = Nothing - , _schemaOneOf = Nothing - , _schemaNot = Nothing - } - -instance FromJSON Schema where - parseJSON = withObject "Schema" $ \o -> do - a <- o .:! "$schema" - b <- o .:! "id" - c <- o .:! "$ref" - d <- o .:! "definitions" - e <- parseJSON (Object (HM.difference o internalSchemaHashMap)) - - f <- o .:! "multipleOf" - g <- o .:! "maximum" - h <- o .:! "exclusiveMaximum" - i <- o .:! "minimum" - j <- o .:! "exclusiveMinimum" - - k <- o .:! "maxLength" - l <- o .:! "minLength" - m <- o .:! "pattern" - - n <- o .:! "maxItems" - o' <- o .:! "minItems" - p <- o .:! "uniqueItems" - q <- o .:! "items" - r <- o .:! "additionalItems" - - s <- o .:! "maxProperties" - t <- o .:! "minProperties" - u <- o .:! "required" - v <- o .:! "dependencies" - w <- o .:! "properties" - x <- o .:! "patternProperties" - y <- o .:! "additionalProperties" - - z <- o .:! "enum" - a2 <- o .:! "type" - b2 <- fmap _unNonEmpty' <$> o .:! "allOf" - c2 <- fmap _unNonEmpty' <$> o .:! "anyOf" - d2 <- fmap _unNonEmpty' <$> o .:! "oneOf" - e2 <- o .:! "not" - pure Schema - { _schemaVersion = a - , _schemaId = b - , _schemaRef = c - , _schemaDefinitions = d - , _schemaOther = e - - , _schemaMultipleOf = f - , _schemaMaximum = g - , _schemaExclusiveMaximum = h - , _schemaMinimum = i - , _schemaExclusiveMinimum = j - - , _schemaMaxLength = k - , _schemaMinLength = l - , _schemaPattern = m - - , _schemaMaxItems = n - , _schemaMinItems = o' - , _schemaUniqueItems = p - , _schemaItems = q - , _schemaAdditionalItems = r - - , _schemaMaxProperties = s - , _schemaMinProperties = t - , _schemaRequired = u - , _schemaDependencies = v - , _schemaProperties = w - , _schemaPatternProperties = x - , _schemaAdditionalProperties = y - - , _schemaEnum = z - , _schemaType = a2 - , _schemaAllOf = b2 - , _schemaAnyOf = c2 - , _schemaOneOf = d2 - , _schemaNot = e2 - } - -instance ToJSON Schema where - -- | The way we resolve JSON Pointers to embedded schemas is by - -- serializing the containing schema to a value and then resolving the - -- pointer against it. This means that FromJSON and ToJSON must be - -- isomorphic. - -- - -- This influences the design choices in the library. E.g. right now - -- there are two false values for "exclusiveMaximum" -- Nothing and - -- Just False. We could have condensed them down by using () instead - -- of Bool for "exclusiveMaximum". This would have made writing schemas - -- in haskell easier, but we could no longer round trip through/from - -- JSON without losing information. - toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap) - (toJSON <$> _schemaOther s) - where - -- 'mapMaybe' is provided by unordered-containers after - -- unordered-container-2.6.0.0, but until that is a little older - -- (and has time to get into Stackage etc.) we use our own - -- implementation. - mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 - mapMaybe f = fmap fromJust . HM.filter isJust . fmap f - --- | Internal. Separate from ToJSON because it's also used --- by FromJSON to determine what keys aren't official schema --- keys and therefor should be included in _schemaOther. -internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value) -internalSchemaHashMap = HM.fromList - [ ("$schema" , f _schemaVersion) - , ("id" , f _schemaId) - , ("$ref" , f _schemaRef) - , ("definitions" , f _schemaDefinitions) - - , ("multipleOf" , f _schemaMultipleOf) - , ("maximum" , f _schemaMaximum) - , ("exclusiveMaximum" , f _schemaExclusiveMaximum) - , ("minimum" , f _schemaMinimum) - , ("exclusiveMinimum" , f _schemaExclusiveMinimum) - - , ("maxLength" , f _schemaMaxLength) - , ("minLength" , f _schemaMinLength) - , ("pattern" , f _schemaPattern) - - , ("maxItems" , f _schemaMaxItems) - , ("minItems" , f _schemaMinItems) - , ("uniqueItems" , f _schemaUniqueItems) - , ("items" , f _schemaItems) - , ("additionalItems" , f _schemaAdditionalItems) - - , ("maxProperties" , f _schemaMaxProperties) - , ("minProperties" , f _schemaMinProperties) - , ("required" , f _schemaRequired) - , ("dependencies" , f _schemaDependencies) - , ("properties" , f _schemaProperties) - , ("patternProperties" , f _schemaPatternProperties) - , ("additionalProperties", f _schemaAdditionalProperties) - - , ("enum" , f _schemaEnum) - , ("type" , f _schemaType) - , ("allOf" , f (fmap NonEmpty' . _schemaAllOf)) - , ("anyOf" , f (fmap NonEmpty' . _schemaAnyOf)) - , ("oneOf" , f (fmap NonEmpty' . _schemaOneOf)) - , ("not" , f _schemaNot) - ] - where - f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value - f = (fmap.fmap) toJSON - -instance Arbitrary Schema where - arbitrary = sized f - where - maybeGen :: Gen a -> Gen (Maybe a) - maybeGen a = oneof [pure Nothing, Just <$> a] - - maybeRecurse :: Int -> Gen a -> Gen (Maybe a) - maybeRecurse n a - | n < 1 = pure Nothing - | otherwise = maybeGen $ resize (n `div` 10) a - - f :: Int -> Gen Schema - f n = do - 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. - d <- pure Nothing -- _schemaDefinitions - e <- pure mempty -- _otherPairs - - f' <- maybeGen arbitraryPositiveScientific - g <- maybeGen arbitraryScientific - h <- arbitrary - i <- maybeGen arbitraryScientific - j <- arbitrary - - k <- maybeGen (getPositive <$> arbitrary) - l <- maybeGen (getPositive <$> arbitrary) - m <- maybeGen arbitraryText - - n' <- maybeGen (getPositive <$> arbitrary) - o <- maybeGen (getPositive <$> arbitrary) - p <- arbitrary - q <- maybeRecurse n arbitrary - r <- maybeRecurse n arbitrary - - s <- maybeGen (getPositive <$> arbitrary) - t <- maybeGen (getPositive <$> arbitrary) - u <- arbitrary - v <- maybeRecurse n arbitraryHashMap - w <- maybeRecurse n arbitraryHashMap - x <- maybeRecurse n arbitraryHashMap - y <- maybeRecurse n arbitrary - - z <- arbitrary - a2 <- arbitrary - b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) - c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) - d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) - e2 <- maybeRecurse n arbitrary - pure Schema - { _schemaVersion = a - , _schemaId = b - , _schemaRef = c - , _schemaDefinitions = d - , _schemaOther = e - - , _schemaMultipleOf = f' - , _schemaMaximum = g - , _schemaExclusiveMaximum = h - , _schemaMinimum = i - , _schemaExclusiveMinimum = j - - , _schemaMaxLength = k - , _schemaMinLength = l - , _schemaPattern = m - - , _schemaMaxItems = n' - , _schemaMinItems = o - , _schemaUniqueItems = p - , _schemaItems = q - , _schemaAdditionalItems = r - - , _schemaMaxProperties = s - , _schemaMinProperties = t - , _schemaRequired = u - , _schemaDependencies = v - , _schemaProperties = w - , _schemaPatternProperties = x - , _schemaAdditionalProperties = y - - , _schemaEnum = z - , _schemaType = a2 - , _schemaAllOf = b2 - , _schemaAnyOf = c2 - , _schemaOneOf = d2 - , _schemaNot = e2 - } diff --git a/src/Data/JsonSchema/Draft4/Spec.hs b/src/Data/JsonSchema/Draft4/Spec.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4/Spec.hs +++ /dev/null @@ -1,137 +0,0 @@ - -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.Profunctor (Profunctor(..)) - -import Data.JsonSchema.Draft4.Failure -import Data.JsonSchema.Draft4.Schema (Schema(..)) -import Data.JsonSchema.Fetch (ReferencedSchemas(..), - SchemaWithURI(..)) -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.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 - :: ReferencedSchemas Schema - -> SchemaWithURI Schema - -> Value - -> [Failure] -validate rs = continueValidating rs (AN.VisitedSchemas [(Nothing, Nothing)]) - -continueValidating - :: ReferencedSchemas Schema - -> AN.VisitedSchemas - -> SchemaWithURI Schema - -> Value - -> [Failure] -continueValidating referenced visited sw = - JT.validate (d4Spec referenced visited currentScope) - (_swSchema sw) - where - currentScope :: Maybe Text - currentScope = updateResolutionScope - (_swURI sw) - (_schemaId (_swSchema sw)) - -d4Spec - :: ReferencedSchemas Schema - -> AN.VisitedSchemas - -> Maybe Text - -> Spec Schema ValidatorChain -d4Spec referenced visited scope = Spec - [ dimap - (fmap D4.MultipleOf . _schemaMultipleOf) - (toss MultipleOf) - D4.multipleOf - , dimap - (\s -> D4.MaximumContext (fromMaybe False (_schemaExclusiveMaximum s)) - <$> _schemaMaximum s) - maxE - D4.maximumVal - , dimap - (\s -> D4.MinimumContext (fromMaybe False (_schemaExclusiveMinimum s)) - <$> _schemaMinimum s) - minE - D4.minimumVal - - , 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 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 - (\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 - - , 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) - , dimap - (\s -> D4.PatternPropertiesContext - (isNothing (_schemaProperties s)) - (_schemaAdditionalProperties s) - <$> _schemaPatternProperties s) - patPropE - (D4.patternProperties descend) - , dimap - (\s -> D4.AdditionalPropertiesContext - (isNothing (_schemaProperties s) - && isNothing (_schemaPatternProperties s)) - <$> _schemaAdditionalProperties s) - addPropE - (D4.additionalProperties 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) - ] - where - refVal :: AN.VisitedSchemas -> Maybe Text -> Schema -> Value -> [Failure] - refVal newVisited newScope schema = - continueValidating referenced newVisited (SchemaWithURI schema newScope) - - descend :: Schema -> Value -> [Failure] - descend schema = - continueValidating referenced mempty (SchemaWithURI schema scope) - - lateral :: Schema -> Value -> [Failure] - lateral schema = - continueValidating referenced visited (SchemaWithURI schema scope) diff --git a/src/Data/JsonSchema/Fetch.hs b/src/Data/JsonSchema/Fetch.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Fetch.hs +++ /dev/null @@ -1,194 +0,0 @@ - -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.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.Text as T -import qualified Network.HTTP.Client as NC - -import Data.Validator.Reference (resolveReference, - updateResolutionScope) - --------------------------------------------------- --- * Types --------------------------------------------------- - --- | This is all the fetching functions need to know about a particular --- JSON Schema draft, e.g. JSON Schema Draft 4. -data FetchInfo schema = FetchInfo - { _fiEmbedded :: schema -> ([schema], [schema]) - , _fiId :: schema -> Maybe Text - , _fiRef :: schema -> Maybe Text - } - -data ReferencedSchemas schema = ReferencedSchemas - { _rsStarting :: !schema - -- ^ Used to resolve relative references when we don't know what the scope - -- of the current schema is. This only happens with starting schemas - -- because if we're using a remote schema we had to know its URI in order - -- to fetch it. - -- - -- Tracking the starting schema (instead of just resolving the reference to - -- the current schema being used for validation) is necessary for cases - -- where schemas are embedded inside one another. For instance in this - -- case not distinguishing the starting and "foo" schemas sends the code - -- into an infinite loop: - -- - -- { - -- "additionalProperties": false, - -- "properties": { - -- "foo": { - -- "$ref": "#" - -- } - -- } - -- } - , _rsSchemaMap :: !(URISchemaMap schema) - } deriving (Eq, Show) - --- | Keys are URIs (without URI fragments). -type URISchemaMap schema = HashMap Text schema - -data SchemaWithURI schema = SchemaWithURI - { _swSchema :: !schema - , _swURI :: !(Maybe Text) - -- ^ This is the URI identifying the document containing the schema. - -- It's different than the schema's "id" field, which controls scope - -- when resolving references contained in the schema. - - -- TODO: Make the no URI fragment requirement unnecessary. - } deriving (Eq, Show) - -getReference :: ReferencedSchemas schema -> Maybe Text -> Maybe schema -getReference referenced Nothing = Just (_rsStarting referenced) -getReference referenced (Just t) = H.lookup t (_rsSchemaMap referenced) - --------------------------------------------------- --- * Fetch via HTTP --------------------------------------------------- - -data HTTPFailure - = HTTPParseFailure Text - | HTTPRequestFailure NC.HttpException - deriving Show - --- | Take a schema. Retrieve every document either it or its subschemas --- include via the "$ref" keyword. -referencesViaHTTP' - :: forall schema. FromJSON schema - => FetchInfo schema - -> SchemaWithURI schema - -> IO (Either HTTPFailure (URISchemaMap schema)) -referencesViaHTTP' info sw = do - manager <- NC.newManager NC.defaultManagerSettings - let f = referencesMethodAgnostic (get manager) info sw - catch (left HTTPParseFailure <$> f) handler - where - get :: NC.Manager -> Text -> IO LBS.ByteString - get man url = do - request <- NC.parseUrlThrow (T.unpack url) - NC.responseBody <$> NC.httpLbs request man - - handler - :: NC.HttpException - -> IO (Either HTTPFailure (URISchemaMap schema)) - handler = pure . Left . HTTPRequestFailure - --------------------------------------------------- --- * Fetch via Filesystem --------------------------------------------------- - -data FilesystemFailure - = FSParseFailure Text - | FSReadFailure IOError - deriving (Show, Eq) - -referencesViaFilesystem' - :: forall schema. FromJSON schema - => FetchInfo schema - -> SchemaWithURI schema - -> IO (Either FilesystemFailure (URISchemaMap schema)) -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 - - handler - :: IOError - -> IO (Either FilesystemFailure (URISchemaMap schema)) - handler = pure . Left . FSReadFailure - --------------------------------------------------- --- * Method Agnostic Fetching Tools --------------------------------------------------- - --- | A version of 'fetchReferencedSchema's where the function to fetch --- schemas is provided by the user. This allows restrictions to be added, --- e.g. rejecting non-local URIs. -referencesMethodAgnostic - :: forall schema. FromJSON schema - => (Text -> IO LBS.ByteString) - -> FetchInfo schema - -> SchemaWithURI schema - -> IO (Either Text (URISchemaMap schema)) -referencesMethodAgnostic fetchRef info = - getRecursiveReferences fetchRef info mempty - -getRecursiveReferences - :: forall schema. FromJSON schema - => (Text -> IO LBS.ByteString) - -> FetchInfo schema - -> URISchemaMap schema - -> SchemaWithURI schema - -> IO (Either Text (URISchemaMap schema)) -getRecursiveReferences fetchRef info referenced sw = - foldM f (Right referenced) (includeSubschemas info sw) - where - f :: Either Text (URISchemaMap schema) - -> SchemaWithURI schema - -> IO (Either Text (URISchemaMap schema)) - f (Left e) _ = pure (Left e) - f (Right g) (SchemaWithURI schema mUri) = - case newRef of - Nothing -> pure (Right g) - Just uri -> do - bts <- fetchRef uri - case eitherDecode bts of - Left e -> pure . Left . T.pack $ e - Right schm -> getRecursiveReferences - fetchRef info (H.insert uri schm g) - (SchemaWithURI schm (Just uri)) - where - newRef :: Maybe Text - newRef - | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema - = case H.lookup uri g of - Nothing -> Just uri - Just _ -> Nothing - | otherwise = Nothing - --- | Return the schema passed in as an argument, as well as every --- subschema contained within it. -includeSubschemas - :: forall schema. - FetchInfo schema - -> SchemaWithURI schema - -> [SchemaWithURI schema] -includeSubschemas info (SchemaWithURI schema mUri) = - SchemaWithURI schema mUri - : (includeSubschemas info =<< subSchemas) - where - subSchemas :: [SchemaWithURI schema] - subSchemas = - (\a -> SchemaWithURI a (updateResolutionScope mUri (_fiId info schema))) - <$> uncurry (<>) (_fiEmbedded info schema) diff --git a/src/Data/JsonSchema/Types.hs b/src/Data/JsonSchema/Types.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Types.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Data.JsonSchema.Types where - -import Prelude -import Import - -import Data.Validator.Failure (Fail) -import Data.Validator.Types (Validator(..)) - -newtype Spec schema err - = Spec { _unSpec :: [Validator schema schema err] } - --- | Return a schema's immediate subschemas. --- --- The first list is subschemas validating the same level of the document, --- the second list is subschemas validating lower levels (see --- 'Data.Validator.Types.Fail' for a full explanation). -embedded :: Spec schema a -> schema -> ([schema], [schema]) -embedded spec schema = - let embeds = (\val -> _embedded val schema) <$> _unSpec spec - in foldl' (\(a,b) (x,y) -> (x <> a, y <> b)) (mempty, mempty) embeds - -validate - :: Spec schema err - -> schema - -> Value - -> [Fail err] -validate spec schema v = _unSpec spec >>= (\val -> _validate val schema v) - --- | A basic schema type that doesn't impose much structure. --- --- 'Data.JsonSchema.Draft4' doesn't use this, but instead uses the one --- defined in 'Data.JsonSchema.Draft4.Schema' to make it easier to write --- draft 4 schemas in Haskell. -newtype Schema - = Schema { _unSchema :: HashMap Text Value } - deriving (Eq, Show, FromJSON, ToJSON) diff --git a/src/Data/Validator/Draft4.hs b/src/Data/Validator/Draft4.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4.hs +++ /dev/null @@ -1,550 +0,0 @@ --- | 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 - -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.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.Types (Validator(..)) -import Data.Validator.Utils (fromJSONEither) - --- | For internal use. -run :: FromJSON b => (a -> b -> [c]) -> Maybe a -> Value -> [c] -run _ Nothing _ = mempty -run f (Just a) b = - case fromJSONEither b of - Left _ -> mempty - Right c -> f a c - --- | For internal use. -noEmbedded :: a -> ([b], [b]) -noEmbedded = const (mempty, mempty) - --------------------------------------------------- --- * 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) - -instance FromJSON MinimumContext where - parseJSON = withObject "MinimumContext" $ \o -> MinimumContext - <$> o .:! "exclusiveMinimum" .!= False - <*> o .: "minimum" - -minimumVal :: Validator a (Maybe MinimumContext) NU.MinimumInvalid -minimumVal = - Validator - noEmbedded - (run (\(MinimumContext a b) -> maybeToList . NU.minimumVal a b)) - --------------------------------------------------- --- * 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) - -instance FromJSON PatternVal where - parseJSON = withObject "PatternVal" $ \o -> - PatternVal <$> o .: "pattern" - -patternVal :: Validator a (Maybe PatternVal) () -patternVal = - Validator - noEmbedded - (run (fmap maybeToList . ST.patternVal . _unPatternVal)) - --------------------------------------------------- --- * 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)) - -newtype MinItems - = MinItems { _unMinItems :: Int } - deriving (Eq, Show) - -instance FromJSON MinItems where - parseJSON = withObject "MinItems" $ \o -> - MinItems <$> o .: "minItems" - -minItems :: Validator a (Maybe MinItems) () -minItems = - Validator - noEmbedded - (run (fmap maybeToList . AR.minItems . _unMinItems)) - -newtype UniqueItems - = UniqueItems { _unUniqueItems :: Bool } - deriving (Eq, Show) - -instance FromJSON UniqueItems where - parseJSON = withObject "UniqueItems" $ \o -> - UniqueItems <$> o .: "uniqueItems" - -uniqueItems :: Validator a (Maybe UniqueItems) () -uniqueItems = - Validator - noEmbedded - (run (fmap maybeToList . AR.uniqueItems . _unUniqueItems)) - -data ItemsContext schema = - ItemsContext - (Maybe (AR.AdditionalItems schema)) - (AR.Items schema) - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (ItemsContext schema) where - parseJSON = withObject "ItemsContext" $ \o -> ItemsContext - <$> o .:! "additionalItems" - <*> o .: "items" - -items - :: (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (ItemsContext schema)) (AR.ItemsInvalid err) -items 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" - --- | Since 'items' will always take care of validating 'additionalItems' --- as well, the actual validation side of 'additionalItemsEmbedded' is --- disabled. -additionalItemsEmbedded - :: Validator - schema - (Maybe (AdditionalItemsContext schema)) - err -additionalItemsEmbedded= - Validator - (\a -> case a of - Just (AdditionalItemsContext (AR.AdditionalObject b)) -> - (mempty, pure b) - _ -> (mempty, mempty)) - (const (const mempty)) - -newtype Definitions schema - = Definitions { _unDefinitions :: HashMap Text schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (Definitions schema) where - 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. -definitionsEmbedded - :: Validator - schema - (Maybe (Definitions schema)) - err -definitionsEmbedded = - Validator - (\a -> case a of - Just (Definitions b) -> (mempty, HM.elems b) - Nothing -> (mempty, mempty)) - (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 - :: (FromJSON schema, ToJSON schema) - => AN.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 = - Validator - noEmbedded - (run (fmap maybeToList . AN.typeVal . _unTypeContext)) - -newtype AllOf schema - = AllOf { _unAllOf :: NonEmpty schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AllOf schema) where - parseJSON = withObject "AllOf" $ \o -> - AllOf <$> o .: "allOf" - -allOf - :: (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (AllOf schema)) err -allOf 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" - -anyOf - :: (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (AnyOf schema)) err -anyOf 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" - -oneOf - :: ToJSON schema - => (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (OneOf schema)) (AN.OneOfInvalid err) -oneOf 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" - -notVal - :: ToJSON schema - => (schema -> Value -> [Fail err]) - -> Validator schema (Maybe (NotVal schema)) () -notVal f = - Validator - (\a -> case a of - Just (NotVal b) -> (pure b, mempty) - Nothing -> (mempty, mempty)) - (run (fmap maybeToList . AN.notVal f . _unNotVal)) diff --git a/src/Data/Validator/Draft4/Any.hs b/src/Data/Validator/Draft4/Any.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Any.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# 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 qualified Data.List.NonEmpty as NE -import Data.Maybe -import qualified Data.Scientific as SCI -import Data.Set (Set) -import qualified Data.Set as S - -import Data.Validator.Failure (Fail(..)) -import qualified Data.Validator.Utils as UT -import Data.Validator.Reference (URIBaseAndFragment, - resolveFragment, resolveReference) - --------------------------------------------------- --- * $ref --------------------------------------------------- - -data RefInvalid err - = RefResolution - | RefLoop - | RefInvalid err - deriving (Eq, Show) - -newtype VisitedSchemas - = VisitedSchemas { _unVisited :: [URIBaseAndFragment] } - deriving (Eq, Show, Monoid) - -ref - :: forall err schema. (FromJSON schema, ToJSON schema) - => VisitedSchemas - -> Maybe Text - -> (Maybe Text -> Maybe schema) - -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err]) - -> Text - -> Value - -> [Fail (RefInvalid err)] -ref visited scope getRef f reference x - | (mUri, mFragment) `elem` _unVisited visited = - pure $ Failure RefLoop (toJSON reference) mempty x - | otherwise = - case getRef mUri of - Nothing -> pure failureDNE - Just schema -> - case resolveFragment mFragment schema of - Nothing -> pure failureDNE - Just s -> - let newVisited = (VisitedSchemas [(mUri, mFragment)] - <> visited) - in fmap RefInvalid <$> f newVisited mUri s x - where - (mUri, mFragment) = resolveReference scope reference - - failureDNE :: Fail (RefInvalid err) - failureDNE = Failure RefResolution (toJSON reference) mempty x - --------------------------------------------------- --- * enum --------------------------------------------------- - --- | From the spec: --- --- --- > The value of this keyword MUST be an array. --- > This array MUST have at least one element. --- > Elements in the array MUST be unique. --- --- 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 } - -- 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 Arbitrary EnumVal 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) - where - toUnique :: [Value] -> [Value] - toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue - -enumVal :: EnumVal -> Value -> Maybe (Fail ()) -enumVal (EnumVal vs) x - | not (UT.allUniqueValues' vs) = Nothing - | x `elem` vs = Nothing - | otherwise = Just $ Failure () (toJSON (UT.NonEmpty' vs)) - mempty x - --------------------------------------------------- --- * type --------------------------------------------------- - -data TypeVal - = TypeValString Text - | TypeValArray (Set Text) - deriving (Eq, Show) - -instance FromJSON TypeVal where - parseJSON v = fmap TypeValString (parseJSON v) - <|> fmap TypeValArray (parseJSON v) - -instance ToJSON TypeVal where - toJSON (TypeValString t) = toJSON t - toJSON (TypeValArray ts) = toJSON ts - -instance Arbitrary TypeVal where - arbitrary = oneof [ TypeValString <$> UT.arbitraryText - , TypeValArray <$> UT.arbitrarySetOfText - ] - -setFromTypeVal :: TypeVal -> Set Text -setFromTypeVal (TypeValString t) = S.singleton t -setFromTypeVal (TypeValArray ts) = ts - -typeVal :: TypeVal -> Value -> Maybe (Fail ()) -typeVal tv x - | S.null matches = Just (Failure () (toJSON tv) mempty 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) - - okTypes :: Set Text - okTypes = - case x of - Null -> S.singleton "null" - (Array _) -> S.singleton "array" - (Bool _) -> S.singleton "boolean" - (Object _) -> S.singleton "object" - (String _) -> S.singleton "string" - (Number y) -> - if SCI.isInteger y - then S.fromList ["number", "integer"] - else S.singleton "number" - --------------------------------------------------- --- * allOf --------------------------------------------------- - -allOf - :: (schema -> Value -> [Fail err]) - -> NonEmpty schema - -> Value - -> [Fail err] -allOf f subSchemas x = NE.toList subSchemas >>= flip f x - --------------------------------------------------- --- * anyOf --------------------------------------------------- - -anyOf - :: forall err schema. - (schema -> Value -> [Fail err]) - -> NonEmpty schema - -> Value - -> [Fail err] -anyOf f subSchemas x - | any null results = mempty - | otherwise = concat results - where - results :: [[Fail err]] - results = flip f x <$> NE.toList subSchemas - --------------------------------------------------- --- * oneOf --------------------------------------------------- - -data OneOfInvalid err - = TooManySuccesses - | NoSuccesses err - deriving (Eq, Show) - -oneOf - :: forall err schema. ToJSON schema - => (schema -> Value -> [Fail err]) - -> NonEmpty schema - -> Value - -> [Fail (OneOfInvalid err)] -oneOf f subSchemas x - | length successes == 1 = mempty - | length successes > 1 = pure tooManySuccesses - | otherwise = fmap NoSuccesses <$> concat failures - where - (successes, failures) = partition null results - - results :: [[Fail err]] - results = flip f x <$> NE.toList subSchemas - - -- 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 - --------------------------------------------------- --- * not --------------------------------------------------- - -notVal - :: ToJSON schema - => (schema -> Value -> [Fail err]) - -> schema - -> Value - -> Maybe (Fail ()) -notVal f schema x = - case f schema x of - [] -> Just (Failure () (toJSON schema) mempty x) - _ -> Nothing diff --git a/src/Data/Validator/Draft4/Array.hs b/src/Data/Validator/Draft4/Array.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Array.hs +++ /dev/null @@ -1,184 +0,0 @@ - -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 Data.Validator.Failure (Fail(..), prependToPath) -import Data.Validator.Utils (allUniqueValues) - --------------------------------------------------- --- * maxItems --------------------------------------------------- - --- | The spec requires @"maxItems"@ to be non-negative. -maxItems :: Int -> Vector Value -> Maybe (Fail ()) -maxItems n xs - | n < 0 = Nothing - | V.length xs > n = Just (Failure () (toJSON n) mempty (Array xs)) - | otherwise = Nothing - --------------------------------------------------- --- * minItems --------------------------------------------------- - --- | The spec requires @"minItems"@ to be non-negative. -minItems :: Int -> Vector Value -> Maybe (Fail ()) -minItems n xs - | n < 0 = Nothing - | V.length xs < n = Just (Failure () (toJSON n) mempty (Array xs)) - | otherwise = Nothing - --------------------------------------------------- --- * uniqueItems --------------------------------------------------- - -uniqueItems :: Bool -> Vector Value -> Maybe (Fail ()) -uniqueItems True xs - | allUniqueValues xs = Nothing - | otherwise = Just (Failure () (Bool True) mempty (Array xs)) -uniqueItems False _ = Nothing - --------------------------------------------------- --- * items --------------------------------------------------- - -data Items schema - = ItemsObject schema - | ItemsArray [schema] - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (Items schema) where - parseJSON v = fmap ItemsObject (parseJSON v) - <|> fmap ItemsArray (parseJSON v) - -instance ToJSON schema => ToJSON (Items schema) where - toJSON (ItemsObject hm) = toJSON hm - toJSON (ItemsArray schemas) = toJSON schemas - -instance Arbitrary schema => Arbitrary (Items schema) where - arbitrary = oneof [ ItemsObject <$> arbitrary - , ItemsArray <$> arbitrary - ] - -data ItemsInvalid err - = Items err - | AdditionalItemsBoolInvalid - | AdditionalItemsObjectInvalid err - deriving (Eq, Show) - -items - :: forall err schema. - (schema -> Value -> [Fail err]) - -> Maybe (AdditionalItems schema) - -> Items 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 - -items f mAdditional (ItemsArray subSchemas) xs = - itemFailures <> additionalItemFailures - 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 [] - - correctName :: AdditionalItemsInvalid err -> ItemsInvalid err - correctName AdditionalBoolInvalid = AdditionalItemsBoolInvalid - correctName (AdditionalObjectInvalid err) = - AdditionalItemsObjectInvalid err - --------------------------------------------------- --- * additionalItems --------------------------------------------------- - -data AdditionalItems schema - = AdditionalBool Bool - | AdditionalObject schema - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AdditionalItems schema) where - parseJSON v = fmap AdditionalBool (parseJSON v) - <|> fmap AdditionalObject (parseJSON v) - -instance ToJSON schema => ToJSON (AdditionalItems schema) where - toJSON (AdditionalBool b) = toJSON b - toJSON (AdditionalObject hm) = toJSON hm - -instance Arbitrary schema => Arbitrary (AdditionalItems schema) where - arbitrary = oneof [ AdditionalBool <$> arbitrary - , AdditionalObject <$> arbitrary - ] - -data AdditionalItemsInvalid err - = AdditionalBoolInvalid - | AdditionalObjectInvalid err - deriving (Eq, Show) - -additionalItems - :: forall err schema. - (schema -> Value -> [Fail 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 diff --git a/src/Data/Validator/Draft4/Number.hs b/src/Data/Validator/Draft4/Number.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Number.hs +++ /dev/null @@ -1,65 +0,0 @@ - -module Data.Validator.Draft4.Number where - -import Import -import Prelude - -import Data.Fixed (mod') -import Data.Scientific (Scientific) - -import Data.Validator.Failure (Fail(..)) - --------------------------------------------------- --- * multipleOf --------------------------------------------------- - --- | The spec requires @"multipleOf"@ to be positive. -multipleOf :: Scientific -> Scientific -> Maybe (Fail ()) -multipleOf n x - | n <= 0 = Nothing - | x `mod'` n /= 0 = Just (Failure () (toJSON n) mempty (Number x)) - | otherwise = Nothing - --------------------------------------------------- --- * maximum --------------------------------------------------- - -data MaximumInvalid - = Maximum - | ExclusiveMaximum - deriving (Eq, Show) - -maximumVal - :: Bool - -> Scientific - -> 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) - --------------------------------------------------- --- * minimum --------------------------------------------------- - -data MinimumInvalid - = Minimum - | ExclusiveMinimum - deriving (Eq, Show) - -minimumVal - :: Bool - -> Scientific - -> 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) diff --git a/src/Data/Validator/Draft4/Object.hs b/src/Data/Validator/Draft4/Object.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Object.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Data.Validator.Draft4.Object - ( module Data.Validator.Draft4.Object - , module Data.Validator.Draft4.Object.Properties - ) 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 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 --------------------------------------------------- - --- | 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 - --------------------------------------------------- --- * minProperties --------------------------------------------------- - --- | 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 - --------------------------------------------------- --- * required --------------------------------------------------- - --- | From the spec: --- --- > 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) - -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." - -instance Arbitrary Required where - arbitrary = do - x <- arbitraryText -- Guarantee at least one element. - xs <- (fmap.fmap) T.pack arbitrary - pure . Required . S.fromList $ x:xs - -required :: Required -> HashMap Text Value -> Maybe (Fail ()) -required (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)) - where - hm :: HashMap Text Bool - hm = foldl (\b a -> H.insert a True b) mempty ts - --------------------------------------------------- --- * dependencies --------------------------------------------------- - -data Dependency schema - = SchemaDependency schema - | PropertyDependency (Set Text) - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (Dependency schema) where - parseJSON v = fmap SchemaDependency (parseJSON v) - <|> fmap PropertyDependency (parseJSON v) - -instance ToJSON schema => ToJSON (Dependency schema) where - toJSON (SchemaDependency schema) = toJSON schema - toJSON (PropertyDependency ts) = toJSON ts - -instance Arbitrary schema => Arbitrary (Dependency schema) where - arbitrary = oneof [ SchemaDependency <$> arbitrary - , PropertyDependency <$> arbitrarySetOfText - ] - -data DependencyInvalid err - = SchemaDependencyInvalid err - | PropertyDependencyInvalid - deriving (Eq, Show) - --- | From the spec: --- --- --- > This keyword's value MUST be an object. --- > Each value of this object MUST be either an object or an array. --- > --- > If the value is an object, it MUST be a valid JSON Schema. --- > This is called a schema dependency. --- > --- > 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 - :: forall err schema. - (schema -> Value -> [Fail err]) - -> HashMap Text (Dependency 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 diff --git a/src/Data/Validator/Draft4/Object/Properties.hs b/src/Data/Validator/Draft4/Object/Properties.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Object/Properties.hs +++ /dev/null @@ -1,214 +0,0 @@ - -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 Data.Validator.Failure (Fail(..), prependToPath) - --- | For internal use. -newtype Remaining - = Remaining { _unRemaining :: HashMap Text Value } - --------------------------------------------------- --- * properties --------------------------------------------------- - -data PropertiesInvalid err - = PropertiesInvalid err - | PropPatternInvalid err - | PropAdditionalInvalid (AdditionalPropertiesInvalid err) - 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 - - mPatProp :: Maybe (HashMap Text Value -> ([Fail err], Remaining)) - mPatProp = patternAndUnmatched f <$> mPat - - patternFailures :: [Fail err] - patternFailures = case mPatProp of - Nothing -> mempty - Just val -> fst (val x) - - remaining2 :: Remaining - remaining2 = case mPatProp of - Nothing -> remaining1 - Just val -> snd . val . _unRemaining $ remaining1 - - additionalFailures :: [Fail (AdditionalPropertiesInvalid err)] - additionalFailures = - case mAdd of - Nothing -> mempty - Just a -> additionalProperties f True a (_unRemaining remaining2) - --------------------------------------------------- --- * patternProperties --------------------------------------------------- - -data PatternPropertiesInvalid err - = PPInvalid err - | PPAdditionalPropertiesInvalid (AdditionalPropertiesInvalid err) - deriving (Eq, Show) - -patternProperties - :: forall err schema. - (schema -> Value -> [Fail err]) - -> Bool - -> Maybe (AdditionalProperties schema) - -> HashMap Text schema - -> HashMap Text Value - -> [Fail (PatternPropertiesInvalid err)] -patternProperties _ False _ _ _ = mempty -patternProperties f _ mAdd patternPropertiesHm x = - (fmap PPInvalid <$> ppFailures) - <> (fmap PPAdditionalPropertiesInvalid <$> addFailures) - where - patternProps :: ([Fail err], Remaining) - patternProps = patternAndUnmatched f patternPropertiesHm x - - (ppFailures, remaining) = patternProps - - addFailures :: [Fail (AdditionalPropertiesInvalid err)] - addFailures = - case mAdd of - Nothing -> mempty - Just a -> additionalProperties f True a (_unRemaining remaining) - -patternAndUnmatched - :: forall err schema. - (schema -> Value -> [Fail err]) - -> HashMap Text schema - -> HashMap Text Value - -> ([Fail err], Remaining) -patternAndUnmatched f patPropertiesHm x = - (HM.foldlWithKey' runVals mempty perhapsMatches, remaining) - where - perhapsMatches :: HashMap Text (Value, [schema]) - perhapsMatches = HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x - where - matchingSchemas - :: HashMap Text schema - -> HashMap Text (Value, [schema]) - -> Text - -> Value - -> HashMap Text (Value, [schema]) - matchingSchemas subSchemas acc k v = - HM.insert k (v, HM.foldlWithKey' (checkKey k) mempty subSchemas) acc - - checkKey - :: Text - -> [schema] - -> Text - -> schema - -> [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 - else acc - - runVals - :: [Fail err] - -> Text - -> (Value, [schema]) - -> [Fail err] - runVals acc k (v,subSchemas) = - (subSchemas >>= (\schema -> prependToPath (AP.Token k) <$> f schema v)) - <> acc - - 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) - -additionalProperties - :: forall err schema. - (schema -> Value -> [Fail err]) - -> Bool - -> AdditionalProperties schema - -> HashMap Text Value - -> [Fail (AdditionalPropertiesInvalid err)] -additionalProperties _ False _ _ = mempty -additionalProperties f _ a x = - case a of - AdditionalPropertiesBool b -> - ($> APBoolInvalid) <$> additionalPropertiesBool b x - AdditionalPropertiesObject b -> - fmap APObjectInvalid <$> additionalPropertiesObject f b x - -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 - -additionalPropertiesObject - :: forall err schema. - (schema -> Value -> [Fail 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 diff --git a/src/Data/Validator/Draft4/String.hs b/src/Data/Validator/Draft4/String.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/String.hs +++ /dev/null @@ -1,45 +0,0 @@ - -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(..)) - --------------------------------------------------- --- * maxLength --------------------------------------------------- - --- | The spec requires @"maxLength"@ to be non-negative. -maxLength :: Int -> Text -> Maybe (Fail ()) -maxLength n x - | n <= 0 = Nothing - | T.length x > n = Just (Failure () (toJSON n) mempty (String x)) - | otherwise = Nothing - --------------------------------------------------- --- * minLength --------------------------------------------------- - --- | The spec requires @"minLength"@ to be non-negative. -minLength :: Int -> Text -> Maybe (Fail ()) -minLength n x - | n <= 0 = Nothing - | T.length x < n = Just (Failure () (toJSON n) mempty (String x)) - | otherwise = Nothing - --------------------------------------------------- --- * pattern --------------------------------------------------- - -patternVal :: Text -> Text -> Maybe (Fail ()) -patternVal t x = - case RE.compileM (encodeUtf8 t) mempty of - Left _ -> Just (Failure () (toJSON t) mempty (String x)) - Right re -> if x RE.=~ re - then Nothing - else Just (Failure () (toJSON t) mempty (String 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 deleted file mode 100644 --- a/src/Data/Validator/Reference.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | JSON Reference is described here: --- --- --- And is extended for JSON Schema here: --- - -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 Network.HTTP.Types.URI (urlDecode) -import System.FilePath ((), dropFileName) - -type URIBase = Maybe Text -type URIBaseAndFragment = (Maybe Text, Maybe Text) - -updateResolutionScope :: URIBase -> Maybe Text -> URIBase -updateResolutionScope mScope idKeyword - | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t - | otherwise = mScope - -resolveReference :: URIBase -> Text -> URIBaseAndFragment -resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t - -resolveFragment - :: (FromJSON schema, ToJSON schema) - => Maybe Text - -> schema - -> Maybe schema -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)) - case fromJSON x of - Error _ -> Nothing - Success schema' -> Just schema' - --------------------------------------------------- --- * Helpers --------------------------------------------------- - -isRemoteReference :: Text -> Bool -isRemoteReference = T.isInfixOf "://" - -baseAndFragment :: Text -> URIBaseAndFragment -baseAndFragment = f . T.splitOn "#" - where - f :: [Text] -> URIBaseAndFragment - f [x] = (g x, Nothing) - f [x,y] = (g x, g y) - f _ = (Nothing, Nothing) - - g "" = Nothing - g x = Just x - -resolveScopeAgainst :: Maybe Text -> Text -> Text -resolveScopeAgainst Nothing t = t -resolveScopeAgainst (Just scope) t - | isRemoteReference t = t - | otherwise = smartAppend - where - -- There shouldn't be a fragment at the end of a scope URI, - -- but just in case a user leaves one in we want to be sure - -- to cut it off before appending. - smartAppend :: Text - smartAppend = - case baseAndFragment scope of - (Just base,_) -> - case T.unpack t of - -- We want "/foo" and "#/bar" to combine into - -- "/foo#/bar" not "/foo/#/bar". - '#':_ -> base <> t - _ -> T.pack (dropFileName (T.unpack base) T.unpack t) - _ -> t diff --git a/src/Data/Validator/Types.hs b/src/Data/Validator/Types.hs deleted file mode 100644 --- a/src/Data/Validator/Types.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} - -module Data.Validator.Types where - -import Prelude - -import Data.Aeson (Value) -import Data.Profunctor (Profunctor(..)) - -import Data.Validator.Failure (Fail) - -data Validator schema val err = Validator - { _embedded :: val -> ([schema], [schema]) - -- ^ The first list is embedded schemas that validate the same piece - -- of data this schema validates (such as schemas embedded in 'allOf'). - -- The second is embedded schemas that validate a subset of that data - -- (such as the schemas embedded in 'items'). - -- - -- 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] - } deriving Functor - -instance Profunctor (Validator schema) where - lmap f (Validator a b) = Validator (lmap f a) (lmap f b) - rmap = fmap diff --git a/src/Data/Validator/Utils.hs b/src/Data/Validator/Utils.hs deleted file mode 100644 --- a/src/Data/Validator/Utils.hs +++ /dev/null @@ -1,137 +0,0 @@ - -module Data.Validator.Utils where - -import Import -import Prelude - -import Control.Arrow -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) -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Vector as V - --------------------------------------------------- --- * QuickCheck --------------------------------------------------- - -arbitraryText :: Gen Text -arbitraryText = T.pack <$> arbitrary - -arbitraryScientific :: Gen Scientific -arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary - -arbitraryPositiveScientific :: Gen Scientific -arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific) - . getPositive - <$> arbitrary - -newtype ArbitraryValue - = ArbitraryValue { _unArbitraryValue :: Value } - deriving (Eq, Show) - -instance Arbitrary ArbitraryValue where - arbitrary = ArbitraryValue <$> sized f - where - f :: Int -> Gen Value - f n | n <= 1 = oneof nonRecursive - | otherwise = oneof $ - fmap (Array . V.fromList) (traverse (const (f (n `div` 10))) - =<< (arbitrary :: Gen [()])) - : fmap (Object . HM.fromList) (traverse (const (g (n `div` 10))) - =<< (arbitrary :: Gen [()])) - : nonRecursive - - g :: Int -> Gen (Text, Value) - g n = (,) <$> arbitraryText <*> f n - - nonRecursive :: [Gen Value] - nonRecursive = - [ pure Null - , Bool <$> arbitrary - , String <$> arbitraryText - , Number <$> arbitraryScientific - ] - -arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a) -arbitraryHashMap = HM.fromList . fmap (first T.pack) <$> arbitrary - -arbitrarySetOfText :: Gen (Set Text) -arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary - -newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a } - -instance FromJSON a => FromJSON (NonEmpty' a) where - parseJSON v = do - xs <- parseJSON v - case NE.nonEmpty xs of - Nothing -> fail "Must have at least one item." - Just ne -> pure (NonEmpty' ne) - -instance ToJSON a => ToJSON (NonEmpty' a) where - toJSON = toJSON . NE.toList . _unNonEmpty' - -instance Arbitrary a => Arbitrary (NonEmpty' a) where - arbitrary = do - xs <- arbitrary - case NE.nonEmpty xs of - Nothing -> NonEmpty' . pure <$> arbitrary - Just ne -> pure (NonEmpty' ne) - --------------------------------------------------- --- * allUniqueValues --------------------------------------------------- - -allUniqueValues :: Vector Value -> Bool -allUniqueValues = allUnique . fmap OrdValue . V.toList - --- NOTE: When we no longer support GHC 7.8 we can generalize --- allUnique to work on any Foldable and remove this function. -allUniqueValues' :: NonEmpty Value -> Bool -allUniqueValues' = allUnique . fmap OrdValue . NE.toList - -allUnique :: (Ord a) => [a] -> Bool -allUnique xs = S.size (S.fromList xs) == length xs - --- | OrdValue's Ord instance needs benchmarking, but it allows us to --- use our 'allUnique' function instead of O(n^2) nub, so it's probably --- worth it. -newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq - -instance Ord OrdValue where - (OrdValue Null) `compare` (OrdValue Null) = EQ - (OrdValue Null) `compare` _ = LT - _ `compare` (OrdValue Null) = GT - - (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y - (OrdValue (Bool _)) `compare` _ = LT - _ `compare` (OrdValue (Bool _)) = GT - - (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y - (OrdValue (Number _)) `compare` _ = LT - _ `compare` (OrdValue (Number _)) = GT - - (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y - (OrdValue (String _)) `compare` _ = LT - _ `compare` (OrdValue (String _)) = GT - - (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) = - (OrdValue <$> xs) `compare` (OrdValue <$> ys) - (OrdValue (Array _)) `compare` _ = LT - _ `compare` (OrdValue (Array _)) = GT - - (OrdValue (Object x)) `compare` (OrdValue (Object y)) = - HM.toList (OrdValue <$> x) `compare` HM.toList (OrdValue <$> y) - --------------------------------------------------- --- * other --------------------------------------------------- - -fromJSONEither :: FromJSON a => Value -> Either Text a -fromJSONEither a = - case fromJSON a of - Error e -> Left (T.pack e) - Success b -> Right b diff --git a/src/Import.hs b/src/Import.hs --- a/src/Import.hs +++ b/src/Import.hs @@ -1,12 +1,19 @@ -module Import (module Export) where +module Import (module Export, fromJSONEither) where -import Control.Applicative as Export -import Data.Aeson as Export -import Data.Foldable as Export +import Protolude as Export + +import Data.Aeson 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.Vector as Export (Vector) -import Test.QuickCheck as Export hiding (Failure, Result, Success) +import Data.List.NonEmpty as Export (NonEmpty) +import Data.Vector as Export (Vector) +import Test.QuickCheck as Export hiding (Failure, Result, Success, + (.&.)) + +import qualified Data.Text as T + +fromJSONEither :: FromJSON a => Value -> Either Text a +fromJSONEither a = + case fromJSON a of + Error e -> Left (T.pack e) + Success b -> Right b diff --git a/src/JSONSchema/Draft4.hs b/src/JSONSchema/Draft4.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Draft4.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE TemplateHaskell #-} + +module JSONSchema.Draft4 + ( -- * Draft 4 Schema + SchemaWithURI(..) + , Schema(..) + , SC.emptySchema + + -- * One-step validation (getting references over HTTP) + , fetchHTTPAndValidate + , HTTPValidationFailure(..) + , FE.HTTPFailure(..) + , SchemaInvalid(..) + + -- * One-step validation (getting references from the filesystem) + , fetchFilesystemAndValidate + , FilesystemValidationFailure(..) + , FE.FilesystemFailure(..) + + -- * Validation failure + , Invalid(..) + , ValidatorFailure(..) + + -- * Fetching tools + , URISchemaMap(..) + , referencesViaHTTP + , referencesViaFilesystem + + -- * Other Draft 4 things exported just in case + , metaSchema + , metaSchemaBytes + , schemaValidity + , referencesValidity + , checkSchema + , draft4FetchInfo + ) where + +import Import + +import qualified Data.ByteString as BS +import Data.FileEmbed (embedFile, makeRelativeToProject) +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) + +import JSONSchema.Draft4.Failure (Invalid(..), SchemaInvalid(..), + ValidatorFailure(..)) +import JSONSchema.Draft4.Schema (Schema) +import qualified JSONSchema.Draft4.Schema as SC +import qualified JSONSchema.Draft4.Spec as Spec +import JSONSchema.Fetch (SchemaWithURI(..), URISchemaMap(..)) +import qualified JSONSchema.Fetch as FE + +data HTTPValidationFailure + = HVRequest FE.HTTPFailure + | HVSchema SchemaInvalid + | HVData Invalid + deriving Show + +-- | Fetch recursively referenced schemas over HTTP, check that both the +-- original and referenced schemas are valid, then validate then data. +fetchHTTPAndValidate + :: SchemaWithURI Schema + -> Value + -> IO (Either HTTPValidationFailure ()) +fetchHTTPAndValidate sw v = do + res <- referencesViaHTTP sw + pure (g =<< f =<< first HVRequest res) + where + f :: FE.URISchemaMap Schema + -> Either HTTPValidationFailure (Value -> [ValidatorFailure]) + f references = first HVSchema (checkSchema references sw) + + 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 SchemaInvalid + | FVData Invalid + deriving (Show, Eq) + +-- | 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 + -> IO (Either FilesystemValidationFailure ()) +fetchFilesystemAndValidate sw v = do + res <- referencesViaFilesystem sw + pure (g =<< f =<< first FVRead res) + where + f :: FE.URISchemaMap Schema + -> Either FilesystemValidationFailure (Value -> [ValidatorFailure]) + f references = first FVSchema (checkSchema references sw) + + 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 'JSONSchema.Fetch.FetchInfo' specialized for +-- JSON Schema Draft 4. +draft4FetchInfo :: FE.FetchInfo Schema +draft4FetchInfo = FE.FetchInfo Spec.embedded SC._schemaId SC._schemaRef + +-- | Fetch the schemas recursively referenced by a starting schema over HTTP. +referencesViaHTTP + :: SchemaWithURI Schema + -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema)) +referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo + +-- | Fetch the schemas recursively referenced by a starting schema from +-- the filesystem. +referencesViaFilesystem + :: SchemaWithURI Schema + -> IO (Either FE.FilesystemFailure (FE.URISchemaMap Schema)) +referencesViaFilesystem = FE.referencesViaFilesystem' draft4FetchInfo + +-- | 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 SchemaInvalid (Value -> [ValidatorFailure]) +checkSchema sm sw = + case NE.nonEmpty failures of + Just fs -> Left (SchemaInvalid fs) + Nothing -> Right (Spec.specValidate sm sw) + where + 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 (panic "Schema decode failed (this should never happen)") + . decodeStrict + $ metaSchemaBytes + +metaSchemaBytes :: BS.ByteString +metaSchemaBytes = + $(makeRelativeToProject "src/draft4.json" >>= embedFile) + +-- | Check that a schema itself is valid +-- (if so the returned list will be empty). +schemaValidity :: Schema -> [ValidatorFailure] +schemaValidity = + Spec.specValidate schemaMap (SchemaWithURI metaSchema Nothing) . toJSON + where + schemaMap :: URISchemaMap Schema + schemaMap = + URISchemaMap (HM.singleton "http://json-schema.org/draft-04/schema" + metaSchema) + +-- | Check that a set of referenced schemas are valid +-- (if so the returned list will be empty). +referencesValidity + :: FE.URISchemaMap Schema + -> [(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, NonEmpty ValidatorFailure)] + -> Text + -> Schema + -> [(Text, NonEmpty ValidatorFailure)] + f acc k v = case NE.nonEmpty (schemaValidity v) of + Nothing -> acc + Just errs -> (k,errs) : acc diff --git a/src/JSONSchema/Draft4/Failure.hs b/src/JSONSchema/Draft4/Failure.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Draft4/Failure.hs @@ -0,0 +1,58 @@ +module JSONSchema.Draft4.Failure where + +import Import + +import JSONSchema.Draft4.Schema (Schema) +import qualified JSONSchema.Validator.Draft4 as VAL + +-- | 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) + +data ValidatorFailure + = FailureMultipleOf VAL.MultipleOfInvalid + | FailureMaximum VAL.MaximumInvalid + | FailureMinimum VAL.MinimumInvalid + + | FailureMaxLength VAL.MaxLengthInvalid + | FailureMinLength VAL.MinLengthInvalid + | FailurePattern VAL.PatternInvalid + + | FailureMaxItems VAL.MaxItemsInvalid + | FailureMinItems VAL.MinItemsInvalid + | FailureUniqueItems VAL.UniqueItemsInvalid + | FailureItems (VAL.ItemsInvalid ValidatorFailure) + | FailureAdditionalItems (VAL.AdditionalItemsInvalid ValidatorFailure) + + | FailureMaxProperties VAL.MaxPropertiesInvalid + | FailureMinProperties VAL.MinPropertiesInvalid + | FailureRequired VAL.RequiredInvalid + | FailureDependencies (VAL.DependenciesInvalid ValidatorFailure) + | FailurePropertiesRelated (VAL.PropertiesRelatedInvalid ValidatorFailure) + + | FailureRef (VAL.RefInvalid ValidatorFailure) + | FailureEnum VAL.EnumInvalid + | FailureType VAL.TypeValidatorInvalid + | FailureAllOf (VAL.AllOfInvalid ValidatorFailure) + | FailureAnyOf (VAL.AnyOfInvalid ValidatorFailure) + | FailureOneOf (VAL.OneOfInvalid ValidatorFailure) + | FailureNot VAL.NotValidatorInvalid + deriving (Eq, Show) + +-- | 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/JSONSchema/Draft4/Schema.hs b/src/JSONSchema/Draft4/Schema.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Draft4/Schema.hs @@ -0,0 +1,341 @@ +module JSONSchema.Draft4.Schema where + +import Import hiding (mapMaybe) + +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 JSONSchema.Validator.Draft4 as D4 +import JSONSchema.Validator.Utils + +data Schema = Schema + { _schemaVersion :: Maybe Text + , _schemaId :: Maybe Text + , _schemaRef :: Maybe Text + , _schemaDefinitions :: Maybe (HashMap Text Schema) + -- ^ A standardized location for embedding schemas + -- to be referenced from elsewhere in the document. + , _schemaOther :: HashMap Text Value + -- ^ Since the JSON document this schema was built from could + -- 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 + , _schemaExclusiveMaximum :: Maybe Bool + , _schemaMinimum :: Maybe Scientific + , _schemaExclusiveMinimum :: Maybe Bool + + , _schemaMaxLength :: Maybe Int + , _schemaMinLength :: Maybe Int + , _schemaPattern :: Maybe Text + + , _schemaMaxItems :: Maybe Int + , _schemaMinItems :: Maybe Int + , _schemaUniqueItems :: Maybe Bool + , _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 (D4.AdditionalItems Schema) + + , _schemaMaxProperties :: Maybe Int + , _schemaMinProperties :: Maybe Int + , _schemaRequired :: Maybe (Set Text) + , _schemaDependencies :: Maybe (HashMap Text (D4.Dependency Schema)) + , _schemaProperties :: Maybe (HashMap Text Schema) + , _schemaPatternProperties :: Maybe (HashMap Text Schema) + , _schemaAdditionalProperties :: Maybe (D4.AdditionalProperties Schema) + + , _schemaEnum :: Maybe (NonEmpty Value) + , _schemaType :: Maybe D4.TypeValidator + , _schemaAllOf :: Maybe (NonEmpty Schema) + , _schemaAnyOf :: Maybe (NonEmpty Schema) + , _schemaOneOf :: Maybe (NonEmpty Schema) + , _schemaNot :: Maybe Schema + } deriving (Eq, Show) + +emptySchema :: Schema +emptySchema = Schema + { _schemaVersion = Nothing + , _schemaId = Nothing + , _schemaRef = Nothing + , _schemaDefinitions = Nothing + , _schemaOther = mempty + + , _schemaMultipleOf = Nothing + , _schemaMaximum = Nothing + , _schemaExclusiveMaximum = Nothing + , _schemaMinimum = Nothing + , _schemaExclusiveMinimum = Nothing + + , _schemaMaxLength = Nothing + , _schemaMinLength = Nothing + , _schemaPattern = Nothing + + , _schemaMaxItems = Nothing + , _schemaMinItems = Nothing + , _schemaUniqueItems = Nothing + , _schemaItems = Nothing + , _schemaAdditionalItems = Nothing + + , _schemaMaxProperties = Nothing + , _schemaMinProperties = Nothing + , _schemaRequired = Nothing + , _schemaDependencies = Nothing + , _schemaProperties = Nothing + , _schemaPatternProperties = Nothing + , _schemaAdditionalProperties = Nothing + + , _schemaEnum = Nothing + , _schemaType = Nothing + , _schemaAllOf = Nothing + , _schemaAnyOf = Nothing + , _schemaOneOf = Nothing + , _schemaNot = Nothing + } + +instance FromJSON Schema where + parseJSON = withObject "Schema" $ \o -> do + a <- o .:! "$schema" + b <- o .:! "id" + c <- o .:! "$ref" + d <- o .:! "definitions" + e <- parseJSON (Object (HM.difference o internalSchemaHashMap)) + + f <- o .:! "multipleOf" + g <- o .:! "maximum" + h <- o .:! "exclusiveMaximum" + i <- o .:! "minimum" + j <- o .:! "exclusiveMinimum" + + k <- o .:! "maxLength" + l <- o .:! "minLength" + m <- o .:! "pattern" + + n <- o .:! "maxItems" + o' <- o .:! "minItems" + p <- o .:! "uniqueItems" + q <- o .:! "items" + r <- o .:! "additionalItems" + + s <- o .:! "maxProperties" + t <- o .:! "minProperties" + u <- o .:! "required" + v <- o .:! "dependencies" + w <- o .:! "properties" + x <- o .:! "patternProperties" + y <- o .:! "additionalProperties" + + z <- o .:! "enum" + a2 <- o .:! "type" + b2 <- fmap _unNonEmpty' <$> o .:! "allOf" + c2 <- fmap _unNonEmpty' <$> o .:! "anyOf" + d2 <- fmap _unNonEmpty' <$> o .:! "oneOf" + e2 <- o .:! "not" + pure Schema + { _schemaVersion = a + , _schemaId = b + , _schemaRef = c + , _schemaDefinitions = d + , _schemaOther = e + + , _schemaMultipleOf = f + , _schemaMaximum = g + , _schemaExclusiveMaximum = h + , _schemaMinimum = i + , _schemaExclusiveMinimum = j + + , _schemaMaxLength = k + , _schemaMinLength = l + , _schemaPattern = m + + , _schemaMaxItems = n + , _schemaMinItems = o' + , _schemaUniqueItems = p + , _schemaItems = q + , _schemaAdditionalItems = r + + , _schemaMaxProperties = s + , _schemaMinProperties = t + , _schemaRequired = u + , _schemaDependencies = v + , _schemaProperties = w + , _schemaPatternProperties = x + , _schemaAdditionalProperties = y + + , _schemaEnum = z + , _schemaType = a2 + , _schemaAllOf = b2 + , _schemaAnyOf = c2 + , _schemaOneOf = d2 + , _schemaNot = e2 + } + +instance ToJSON Schema where + -- | The way we resolve JSON Pointers to embedded schemas is by + -- serializing the containing schema to a value and then resolving the + -- pointer against it. This means that FromJSON and ToJSON must be + -- isomorphic. + -- + -- This influences the design choices in the library. E.g. right now + -- there are two false values for "exclusiveMaximum" -- Nothing and + -- Just False. We could have condensed them down by using () instead + -- of Bool for "exclusiveMaximum". This would have made writing schemas + -- in haskell easier, but we could no longer round trip through/from + -- JSON without losing information. + toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap) + (toJSON <$> _schemaOther s) + where + -- 'mapMaybe' is provided by unordered-containers after + -- unordered-container-2.6.0.0, but until that is a little older + -- (and has time to get into Stackage etc.) we use our own + -- implementation. + mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 + mapMaybe f = fmap fromJust . HM.filter isJust . fmap f + +-- | Internal. Separate from ToJSON because it's also used +-- by FromJSON to determine what keys aren't official schema +-- keys and therefor should be included in _schemaOther. +internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value) +internalSchemaHashMap = HM.fromList + [ ("$schema" , f _schemaVersion) + , ("id" , f _schemaId) + , ("$ref" , f _schemaRef) + , ("definitions" , f _schemaDefinitions) + + , ("multipleOf" , f _schemaMultipleOf) + , ("maximum" , f _schemaMaximum) + , ("exclusiveMaximum" , f _schemaExclusiveMaximum) + , ("minimum" , f _schemaMinimum) + , ("exclusiveMinimum" , f _schemaExclusiveMinimum) + + , ("maxLength" , f _schemaMaxLength) + , ("minLength" , f _schemaMinLength) + , ("pattern" , f _schemaPattern) + + , ("maxItems" , f _schemaMaxItems) + , ("minItems" , f _schemaMinItems) + , ("uniqueItems" , f _schemaUniqueItems) + , ("items" , f _schemaItems) + , ("additionalItems" , f _schemaAdditionalItems) + + , ("maxProperties" , f _schemaMaxProperties) + , ("minProperties" , f _schemaMinProperties) + , ("required" , f _schemaRequired) + , ("dependencies" , f _schemaDependencies) + , ("properties" , f _schemaProperties) + , ("patternProperties" , f _schemaPatternProperties) + , ("additionalProperties", f _schemaAdditionalProperties) + + , ("enum" , f _schemaEnum) + , ("type" , f _schemaType) + , ("allOf" , f (fmap NonEmpty' . _schemaAllOf)) + , ("anyOf" , f (fmap NonEmpty' . _schemaAnyOf)) + , ("oneOf" , f (fmap NonEmpty' . _schemaOneOf)) + , ("not" , f _schemaNot) + ] + where + f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value + f = (fmap.fmap) toJSON + +instance Arbitrary Schema where + arbitrary = sized f + where + maybeGen :: Gen a -> Gen (Maybe a) + maybeGen a = oneof [pure Nothing, Just <$> a] + + maybeRecurse :: Int -> Gen a -> Gen (Maybe a) + maybeRecurse n a + | n < 1 = pure Nothing + | otherwise = maybeGen $ resize (n `div` 10) a + + f :: Int -> Gen Schema + f n = do + 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 the + -- invertability of these fields. + d <- pure Nothing -- _schemaDefinitions + e <- pure mempty -- _otherPairs + + f' <- maybeGen arbitraryPositiveScientific + g <- maybeGen arbitraryScientific + h <- arbitrary + i <- maybeGen arbitraryScientific + j <- arbitrary + + k <- maybeGen (getPositive <$> arbitrary) + l <- maybeGen (getPositive <$> arbitrary) + m <- maybeGen arbitraryText + + n' <- maybeGen (getPositive <$> arbitrary) + o <- maybeGen (getPositive <$> arbitrary) + p <- arbitrary + q <- maybeRecurse n arbitrary + r <- maybeRecurse n arbitrary + + s <- maybeGen (getPositive <$> arbitrary) + t <- maybeGen (getPositive <$> 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 <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty' + <$> arbitrary) + a2 <- arbitrary + b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) + c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) + d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) + e2 <- maybeRecurse n arbitrary + pure Schema + { _schemaVersion = a + , _schemaId = b + , _schemaRef = c + , _schemaDefinitions = d + , _schemaOther = e + + , _schemaMultipleOf = f' + , _schemaMaximum = g + , _schemaExclusiveMaximum = h + , _schemaMinimum = i + , _schemaExclusiveMinimum = j + + , _schemaMaxLength = k + , _schemaMinLength = l + , _schemaPattern = m + + , _schemaMaxItems = n' + , _schemaMinItems = o + , _schemaUniqueItems = p + , _schemaItems = q + , _schemaAdditionalItems = r + + , _schemaMaxProperties = s + , _schemaMinProperties = t + , _schemaRequired = u + , _schemaDependencies = v + , _schemaProperties = w + , _schemaPatternProperties = x + , _schemaAdditionalProperties = y + + , _schemaEnum = z + , _schemaType = a2 + , _schemaAllOf = b2 + , _schemaAnyOf = c2 + , _schemaOneOf = d2 + , _schemaNot = e2 + } diff --git a/src/JSONSchema/Draft4/Spec.hs b/src/JSONSchema/Draft4/Spec.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Draft4/Spec.hs @@ -0,0 +1,150 @@ +module JSONSchema.Draft4.Spec where + +import Import + +import Data.Maybe (fromMaybe) +import Data.Profunctor (Profunctor(..)) + +import JSONSchema.Draft4.Failure +import JSONSchema.Draft4.Schema (Schema(..), emptySchema) +import JSONSchema.Fetch (SchemaWithURI(..), URISchemaMap(..)) +import qualified JSONSchema.Fetch as FE +import JSONSchema.Types (Spec(..)) +import qualified JSONSchema.Types as JT +import JSONSchema.Validator.Draft4 +import JSONSchema.Validator.Reference (BaseURI(..), Scope(..), + updateResolutionScope) + +-- | An implementation of 'JT.embedded'. +embedded :: Schema -> ([Schema], [Schema]) +embedded s = + JT.embedded (d4Spec mempty mempty (Scope s Nothing (BaseURI Nothing))) s + +specValidate + :: URISchemaMap Schema + -> SchemaWithURI Schema + -> Value + -> [ValidatorFailure] +specValidate schemaMap sw = + JT.validate (d4Spec schemaMap visited scope) (_swSchema sw) + where + visited :: VisitedSchemas + visited = VisitedSchemas [(Nothing, Nothing)] + + scope :: Scope Schema + scope = Scope + { _topLevelDocument = _swSchema sw + , _documentURI = _swURI sw + , _currentBaseURI = updateResolutionScope (BaseURI (_swURI sw)) + (_schemaId (_swSchema sw)) + } + +validateSubschema + :: URISchemaMap Schema + -> VisitedSchemas + -> Scope Schema + -> Schema + -> Value + -> [ValidatorFailure] +validateSubschema schemaMap visited scope schema = + JT.validate (d4Spec schemaMap visited newScope) schema + where + newScope :: Scope Schema + newScope = scope + { _currentBaseURI = updateResolutionScope (_currentBaseURI scope) + (_schemaId schema) + } + +d4Spec + :: URISchemaMap Schema + -> VisitedSchemas + -> Scope Schema + -> Spec Schema ValidatorFailure +d4Spec schemaMap visited scope = Spec $ + [ dimap + (fmap Ref . _schemaRef) + FailureRef + (refValidator (FE.getReference schemaMap) updateScope valRef visited scope) + ] + + <> fmap (lmap disableIfRefPresent) + [ dimap (fmap MultipleOf . _schemaMultipleOf) FailureMultipleOf multipleOfValidator + , dimap + (\s -> Maximum (fromMaybe False (_schemaExclusiveMaximum s)) <$> _schemaMaximum s) + FailureMaximum + maximumValidator + , dimap + (\s -> Minimum (fromMaybe False (_schemaExclusiveMinimum s)) <$> _schemaMinimum s) + FailureMinimum + minimumValidator + + , dimap (fmap MaxLength . _schemaMaxLength) FailureMaxLength maxLengthValidator + , dimap (fmap MinLength . _schemaMinLength) FailureMinLength minLengthValidator + , dimap (fmap PatternValidator . _schemaPattern) FailurePattern patternValidator + + , dimap (fmap MaxItems . _schemaMaxItems) FailureMaxItems maxItemsValidator + , dimap (fmap MinItems . _schemaMinItems) FailureMinItems minItemsValidator + , dimap (fmap UniqueItems . _schemaUniqueItems) FailureUniqueItems uniqueItemsValidator + , dimap + (\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 MaxProperties . _schemaMaxProperties) + FailureMaxProperties + maxPropertiesValidator + , dimap + (fmap MinProperties . _schemaMinProperties) + FailureMinProperties + minPropertiesValidator + , dimap (fmap Required . _schemaRequired) FailureRequired requiredValidator + , dimap + (fmap DependenciesValidator . _schemaDependencies) + FailureDependencies + (dependenciesValidator descend) + , dimap + (\s -> PropertiesRelated + { _propProperties = _schemaProperties s + , _propPattern = _schemaPatternProperties s + , _propAdditional = _schemaAdditionalProperties s + }) + FailurePropertiesRelated + (propertiesRelatedValidator descend) + + , 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 + disableIfRefPresent :: Schema -> Schema + disableIfRefPresent schema = + case _schemaRef schema of + Nothing -> schema + Just _ -> emptySchema + + updateScope :: BaseURI -> Schema -> BaseURI + updateScope uri schema = updateResolutionScope uri (_schemaId schema) + + valRef + :: VisitedSchemas + -> Scope Schema + -> Schema + -> Value + -> [ValidatorFailure] + valRef vis sc = JT.validate (d4Spec schemaMap vis sc) + + descend :: Schema -> Value -> [ValidatorFailure] + descend = validateSubschema schemaMap mempty scope + + lateral :: Schema -> Value -> [ValidatorFailure] + lateral = validateSubschema schemaMap visited scope diff --git a/src/JSONSchema/Fetch.hs b/src/JSONSchema/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Fetch.hs @@ -0,0 +1,175 @@ +module JSONSchema.Fetch where + +import Import + +import qualified Control.Exception.Safe as Safe +import Control.Monad (foldM) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM +import qualified Data.Semigroup as S +import qualified Data.Text as T +import qualified Network.HTTP.Client as NC +import qualified Network.HTTP.Client.TLS as NCTLS + +import JSONSchema.Validator.Reference (BaseURI(..), resolveReference, + updateResolutionScope) + +-------------------------------------------------- +-- * Types +-------------------------------------------------- + +-- | This is all the fetching functions need to know about a particular +-- JSON Schema draft, e.g. JSON Schema Draft 4. +data FetchInfo schema = FetchInfo + { _fiEmbedded :: schema -> ([schema], [schema]) + , _fiId :: schema -> Maybe Text + , _fiRef :: schema -> Maybe Text + } + +-- | Keys are URIs (without URI fragments). +newtype URISchemaMap schema + = URISchemaMap { _unURISchemaMap :: HashMap Text schema } + deriving (Eq, Show, S.Semigroup, Monoid) + +-- | A top-level schema along with its location. +data SchemaWithURI schema = SchemaWithURI + { _swSchema :: !schema + , _swURI :: !(Maybe Text) + -- ^ This is the URI from which the document was originally fetched. + -- It's different than the schema's "id" field, which controls scope + -- when resolving references contained in the schema. + } deriving (Eq, Show) + +getReference :: URISchemaMap schema -> Text -> Maybe schema +getReference schemaMap t = HM.lookup t (_unURISchemaMap schemaMap) + +-------------------------------------------------- +-- * Fetch via HTTP +-------------------------------------------------- + +data HTTPFailure + = HTTPParseFailure Text + | HTTPRequestFailure NC.HttpException + deriving Show + +-- | Take a schema. Retrieve every document either it or its subschemas +-- include via the "$ref" keyword. +referencesViaHTTP' + :: forall schema. FromJSON schema + => FetchInfo schema + -> SchemaWithURI schema + -> IO (Either HTTPFailure (URISchemaMap schema)) +referencesViaHTTP' info sw = do + manager <- NC.newManager NCTLS.tlsManagerSettings + let f = referencesMethodAgnostic (getURL manager) info sw + Safe.catch (first HTTPParseFailure <$> f) handler + where + getURL :: NC.Manager -> Text -> IO BS.ByteString + getURL man url = do + request <- NC.parseUrlThrow (T.unpack url) + LBS.toStrict . NC.responseBody <$> NC.httpLbs request man + + handler + :: NC.HttpException + -> IO (Either HTTPFailure (URISchemaMap schema)) + handler = pure . Left . HTTPRequestFailure + +-------------------------------------------------- +-- * Fetch via Filesystem +-------------------------------------------------- + +data FilesystemFailure + = FSParseFailure Text + | FSReadFailure IOException + deriving (Show, Eq) + +referencesViaFilesystem' + :: forall schema. FromJSON schema + => FetchInfo schema + -> SchemaWithURI schema + -> IO (Either FilesystemFailure (URISchemaMap schema)) +referencesViaFilesystem' info sw = + Safe.catch (first FSParseFailure <$> f) handler + where + f :: IO (Either Text (URISchemaMap schema)) + f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw + + handler + :: IOException + -> IO (Either FilesystemFailure (URISchemaMap schema)) + handler = pure . Left . FSReadFailure + +-------------------------------------------------- +-- * Method Agnostic Fetching Tools +-------------------------------------------------- + +-- | A version of 'fetchReferencedSchema's where the function to fetch +-- schemas is provided by the user. This allows restrictions to be added, +-- e.g. rejecting non-local URIs. +referencesMethodAgnostic + :: forall schema. FromJSON schema + => (Text -> IO BS.ByteString) + -> FetchInfo schema + -> SchemaWithURI schema + -> IO (Either Text (URISchemaMap schema)) +referencesMethodAgnostic fetchRef info = + getRecursiveReferences fetchRef info (URISchemaMap mempty) + +getRecursiveReferences + :: forall schema. FromJSON schema + => (Text -> IO BS.ByteString) + -> FetchInfo schema + -> URISchemaMap schema + -> SchemaWithURI schema + -> IO (Either Text (URISchemaMap schema)) +getRecursiveReferences fetchRef info referenced sw = + foldM f (Right referenced) (includeSubschemas info sw) + where + f :: Either Text (URISchemaMap schema) + -> SchemaWithURI schema + -> IO (Either Text (URISchemaMap schema)) + f (Left e) _ = pure (Left e) + f (Right (URISchemaMap schemaMap)) (SchemaWithURI schema mURI) = + case newRef of + Nothing -> pure (Right (URISchemaMap schemaMap)) + Just uri -> do + bts <- fetchRef uri + case eitherDecodeStrict bts of + Left e -> pure . Left . T.pack $ e + Right s -> getRecursiveReferences + fetchRef + info + (URISchemaMap (HM.insert uri s schemaMap)) + (SchemaWithURI s (Just uri)) + where + newRef :: Maybe Text + newRef = do + ref <- _fiRef info schema + + -- Consider the reference before updating the scope. + -- If it's a only a fragment this isn't referencing + -- a new document. + void (fst (resolveReference (BaseURI Nothing) ref)) + + uri <- fst (resolveReference (BaseURI mURI) ref) + case HM.lookup uri schemaMap of + Nothing -> Just uri + Just _ -> Nothing + +-- | Return the schema passed in as an argument, as well as every +-- subschema contained within it. +includeSubschemas + :: forall schema. + FetchInfo schema + -> SchemaWithURI schema + -> [SchemaWithURI schema] +includeSubschemas info (SchemaWithURI schema mURI) = + SchemaWithURI schema mURI + : (includeSubschemas info =<< subSchemas) + where + subSchemas :: [SchemaWithURI schema] + subSchemas = + let newScope = updateResolutionScope (BaseURI mURI) (_fiId info schema) + updateScope s = SchemaWithURI s (_unBaseURI newScope) + in updateScope <$> uncurry (<>) (_fiEmbedded info schema) diff --git a/src/JSONSchema/Types.hs b/src/JSONSchema/Types.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Types.hs @@ -0,0 +1,35 @@ +module JSONSchema.Types where + +import Import + +import JSONSchema.Validator.Types (Validator(..)) + +newtype Spec schema err + = Spec { _unSpec :: [Validator schema schema err] } + +-- | Return a schema's immediate subschemas. +-- +-- The first list is subschemas validating the same level of the document, +-- the second list is subschemas validating lower levels (see +-- 'JSONSchema.Validator.Types.Fail' for a full explanation). +embedded :: Spec schema a -> schema -> ([schema], [schema]) +embedded spec schema = + let embeds = (\val -> _embedded val schema) <$> _unSpec spec + in foldl' (\(a,b) (x,y) -> (x <> a, y <> b)) (mempty, mempty) embeds + +validate + :: Spec schema err + -> schema + -> Value + -> [err] +validate spec schema v = + (\val -> _validate val schema v) =<< _unSpec spec + +-- | A basic schema type that doesn't impose much structure. +-- +-- 'JSONSchema.Draft4' doesn't use this, but instead uses the record based +-- one defined in 'JSONSchema.Draft4.Schema' to make it easier to write +-- draft 4 schemas in Haskell. +newtype Schema + = Schema { _unSchema :: HashMap Text Value } + deriving (Eq, Show, FromJSON, ToJSON) diff --git a/src/JSONSchema/Validator/Draft4.hs b/src/JSONSchema/Validator/Draft4.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4.hs @@ -0,0 +1,242 @@ +-- | Turn the validation functions into actual 'Validator's. +-- +-- This is frankly a lot of busywork. It can perhaps be moved into the +-- validator modules themselves once we're sure this is the right design. +module JSONSchema.Validator.Draft4 + ( module JSONSchema.Validator.Draft4 + , module Export + ) where + +import Import + +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE + +import JSONSchema.Validator.Draft4.Any as Export +import JSONSchema.Validator.Draft4.Array as Export +import JSONSchema.Validator.Draft4.Number as Export +import JSONSchema.Validator.Draft4.Object as Export +import JSONSchema.Validator.Draft4.String as Export +import JSONSchema.Validator.Reference (BaseURI(..), Scope(..)) +import JSONSchema.Validator.Types (Validator(..)) + +-- | For internal use. +-- +-- 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 -> maybeToList (f a c) + +-- | For internal use. +noEmbedded :: a -> ([b], [b]) +noEmbedded = const (mempty, mempty) + +-------------------------------------------------- +-- * Numbers +-------------------------------------------------- + +multipleOfValidator :: Validator a (Maybe MultipleOf) MultipleOfInvalid +multipleOfValidator = Validator noEmbedded (run multipleOfVal) + +maximumValidator :: Validator a (Maybe Maximum) MaximumInvalid +maximumValidator = Validator noEmbedded (run maximumVal) + +minimumValidator :: Validator a (Maybe Minimum) MinimumInvalid +minimumValidator = Validator noEmbedded (run minimumVal) + +-------------------------------------------------- +-- * Strings +-------------------------------------------------- + +maxLengthValidator :: Validator a (Maybe MaxLength) MaxLengthInvalid +maxLengthValidator = Validator noEmbedded (run maxLengthVal) + +minLengthValidator :: Validator a (Maybe MinLength) MinLengthInvalid +minLengthValidator = Validator noEmbedded (run minLengthVal) + +patternValidator :: Validator a (Maybe PatternValidator) PatternInvalid +patternValidator = Validator noEmbedded (run patternVal) + +-------------------------------------------------- +-- * Arrays +-------------------------------------------------- + +maxItemsValidator :: Validator a (Maybe MaxItems) MaxItemsInvalid +maxItemsValidator = Validator noEmbedded (run maxItemsVal) + +minItemsValidator :: Validator a (Maybe MinItems) MinItemsInvalid +minItemsValidator = Validator noEmbedded (run minItemsVal) + +uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid +uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal) + +-- TODO: Add tests to the language agnostic test suite to +-- make sure @"additionalItems"@ subschemas are embedded correctly. +itemsRelatedValidator + :: (schema -> Value -> [err]) + -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err) +itemsRelatedValidator f = + Validator + (\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) + +-------------------------------------------------- +-- * Objects +-------------------------------------------------- + +maxPropertiesValidator + :: Validator + a + (Maybe MaxProperties) + MaxPropertiesInvalid +maxPropertiesValidator = Validator noEmbedded (run maxPropertiesVal) + +minPropertiesValidator + :: Validator + a + (Maybe MinProperties) + MinPropertiesInvalid +minPropertiesValidator = Validator noEmbedded (run minPropertiesVal) + +requiredValidator :: Validator a (Maybe Required) RequiredInvalid +requiredValidator = Validator noEmbedded (run requiredVal) + +dependenciesValidator + :: (schema -> Value -> [err]) + -> Validator + schema + (Maybe (DependenciesValidator schema)) + (DependenciesInvalid err) +dependenciesValidator f = + Validator + (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 + +propertiesRelatedValidator + :: (schema -> Value -> [err]) + -> Validator + schema + (PropertiesRelated schema) + (PropertiesRelatedInvalid err) +propertiesRelatedValidator f = + Validator + (\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 } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (Definitions schema) where + parseJSON = withObject "Definitions" $ \o -> + Definitions <$> o .: "definitions" + +definitionsEmbedded + :: Validator + schema + (Maybe (Definitions schema)) + err +definitionsEmbedded = + Validator + (\a -> case a of + Just (Definitions b) -> (mempty, HM.elems b) + Nothing -> (mempty, mempty)) + (const (const mempty)) + +-------------------------------------------------- +-- * Any +-------------------------------------------------- + +refValidator + :: (FromJSON schema, ToJSON schema) + => (Text -> Maybe schema) + -> (BaseURI -> schema -> BaseURI) + -> (VisitedSchemas -> Scope schema -> schema -> Value -> [err]) + -> VisitedSchemas + -> Scope schema + -> Validator a (Maybe Ref) (RefInvalid err) +refValidator getRef updateScope f visited scope = + Validator + noEmbedded + (run (refVal getRef updateScope f visited scope)) + +enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid +enumValidator = Validator noEmbedded (run enumVal) + +typeValidator :: Validator a (Maybe TypeContext) TypeValidatorInvalid +typeValidator = Validator noEmbedded (run typeVal) + +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 (allOfVal 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 (anyOfVal f)) + +oneOfValidator + :: ToJSON schema + => (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 (oneOfVal f)) + +notValidator + :: ToJSON schema + => (schema -> Value -> [err]) + -> Validator + schema + (Maybe (NotValidator schema)) + NotValidatorInvalid +notValidator f = + Validator + (\a -> case a of + Just (NotValidator b) -> (pure b, mempty) + Nothing -> (mempty, mempty)) + (run (notVal f)) diff --git a/src/JSONSchema/Validator/Draft4/Any.hs b/src/JSONSchema/Validator/Draft4/Any.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Any.hs @@ -0,0 +1,509 @@ +module JSONSchema.Validator.Draft4.Any where + +import Import hiding ((<>)) + +import Data.Aeson.TH (constructorTagModifier) +import Data.Char (toLower) +import qualified Data.HashMap.Strict as HM +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NE +import qualified Data.Scientific as SCI +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text.Encoding.Error (UnicodeException) +import qualified JSONPointer as JP +import Network.HTTP.Types.URI (urlDecode) + +import JSONSchema.Validator.Reference (BaseURI(..), Scope(..), + URIAndFragment, + resolveReference) +import qualified JSONSchema.Validator.Utils as UT + +-------------------------------------------------- +-- * $ref +-------------------------------------------------- + +newtype Ref + = Ref { _unRef :: Text } + deriving (Eq, Show) + +instance FromJSON Ref where + parseJSON = withObject "Ref" $ \o -> + Ref <$> o .: "$ref" + +data 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 JSONPointerError + | RefLoop Text VisitedSchemas URIAndFragment + | RefInvalid Text Value (NonEmpty err) + -- ^ 'Text' is the URI and 'Value' is the linked schema. + deriving (Eq, Show) + +newtype VisitedSchemas + = VisitedSchemas { _unVisited :: [URIAndFragment] } + deriving (Eq, Show, Semigroup, Monoid) + +refVal + :: forall err schema. (FromJSON schema, ToJSON schema) + => (Text -> Maybe schema) + -- ^ Look up a schema. + -> (BaseURI -> schema -> BaseURI) + -- ^ Update scope (needed after moving deeper into nested schemas). + -> (VisitedSchemas -> Scope schema -> schema -> Value -> [err]) + -- ^ Validate data. + -> VisitedSchemas + -> Scope schema + -> Ref + -> Value + -> Maybe (RefInvalid err) +refVal getRef updateScope val visited scope (Ref reference) x + | (mURI, mFragment) `elem` _unVisited visited = + Just (RefLoop reference visited (mURI, mFragment)) + | otherwise = leftToMaybe $ do + + -- Get the referenced document + + (newScope, doc) <- first RefResolution + $ getDocument getRef updateScope scope mURI reference + + -- Get the correct subschema within that document. + + res <- case mFragment of + Nothing -> Right (newScope, doc) + Just fragment -> first RefPointerResolution + $ resolveFragment updateScope newScope fragment + let (finalScope, schema) = res + + -- Check if that schema is valid. + + let newVisited = VisitedSchemas [(_documentURI newScope, mFragment)] + <> visited + failures = val newVisited finalScope schema x + first (RefInvalid reference (toJSON schema)) + . maybeToLeft () + $ NE.nonEmpty failures + where + mURI :: Maybe Text + mFragment :: Maybe Text + (mURI, mFragment) = resolveReference (_currentBaseURI scope) reference + +getDocument + :: forall schema. (Text -> Maybe schema) + -> (BaseURI -> schema -> BaseURI) + -> Scope schema + -> Maybe Text + -> Text + -> Either Text (Scope schema, schema) + -- ^ 'Left' is the URI of the document we failed to resolve. +getDocument getRef updateScope scope mURI reference = + case mURI <* fst (resolveReference (BaseURI Nothing) reference) of + Nothing -> Right topOfThisDoc + Just uri -> + case getRef uri of + Nothing -> Left uri + Just s -> Right ( Scope s mURI (updateScope (BaseURI mURI) s) + , s + ) + where + topOfThisDoc :: (Scope schema, schema) + topOfThisDoc = + ( scope { _currentBaseURI = + updateScope (BaseURI (_documentURI scope)) + (_topLevelDocument scope) + } + , _topLevelDocument scope + ) + +data JSONPointerError + = URLDecodingError UnicodeException + -- ^ Aspirationally internal. + | FormatError JP.FormatError + | ResolutionError JP.ResolutionError + | SubschemaDecodingError Text + -- ^ Aspirationally internal. + deriving (Eq, Show) + +resolveFragment + :: (FromJSON schema, ToJSON schema) + => (BaseURI -> schema -> BaseURI) + -> Scope schema + -> Text + -> Either JSONPointerError (Scope schema, schema) +resolveFragment updateScope scope fragment = do + urlDecoded <- first URLDecodingError + . decodeUtf8' + . urlDecode True + . encodeUtf8 + $ fragment + JP.Pointer tokens <- first FormatError (JP.unescape urlDecoded) + let acc = (toJSON (_topLevelDocument scope), _currentBaseURI scope) + (schemaVal, base) <- foldM go acc tokens + schema <- first SubschemaDecodingError (fromJSONEither schemaVal) + pure (scope { _currentBaseURI = base }, schema) + where + -- We have to step through the document JSON Pointer token + -- by JSON Pointer token so that we can update the scope + -- based on each @"id"@ we encounter. + -- + -- TODO: Do we need specialized code to skip @"id"@s such + -- as property keys that aren't meant to change scope? + -- Perhaps this should be added to the language agnostic + -- test suite as well. + -- + -- In the meantime 'newBaseURIFromFragment' drops all keys + -- from JSON objects except "id", which at least prevents + -- SubschemaDecodingError in a situation where one of the + -- values we step through isn't a valid schema. + go :: (Value, BaseURI) + -> JP.Token + -> Either JSONPointerError (Value, BaseURI) + go (lastVal, baseURI) tok = do + v <- first ResolutionError (JP.resolveToken tok lastVal) + newBase <- newBaseURIFromFragment updateScope baseURI v + Right (v, newBase) + +-- | Update the 'BaseURI' (the store of the current "id" value) +-- after resolving one token of a JSON Pointer and stepping into +-- a new 'Value'. +newBaseURIFromFragment + :: FromJSON schema + => (BaseURI -> schema -> BaseURI) + -> BaseURI + -> Value + -> Either JSONPointerError BaseURI +newBaseURIFromFragment updateScope baseURI v = + case v of + Object hm -> do + let hmWithOnlyId = case HM.lookup idKey hm of + Nothing -> mempty + Just idVal -> HM.singleton idKey idVal + schema <- first SubschemaDecodingError (fromJSONEither (Object hmWithOnlyId)) + Right (updateScope baseURI schema) + _ -> Right baseURI + where + idKey :: Text + idKey = "id" + +-------------------------------------------------- +-- * enum +-------------------------------------------------- + +-- | From the spec: +-- +-- +-- > The value of this keyword MUST be an array. +-- > This array MUST have at least one element. +-- > Elements in the array MUST be unique. +-- +-- NOTE: We don't enforce the uniqueness constraint in the haskell code, +-- but we do in the 'FromJSON' instance. +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 EnumValidator where + parseJSON = withObject "EnumValidator" $ \o -> + EnumValidator <$> o .: "enum" + +instance Arbitrary EnumValidator where + arbitrary = do + xs <- (fmap.fmap) UT._unArbitraryValue arbitrary + case NE.nonEmpty (toUnique xs) of + Nothing -> EnumValidator . pure . UT._unArbitraryValue <$> arbitrary + Just ne -> pure (EnumValidator ne) + where + toUnique :: [Value] -> [Value] + toUnique = fmap UT._unOrdValue + . Set.toList + . Set.fromList + . fmap UT.OrdValue + +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 $ EnumInvalid a x + +-------------------------------------------------- +-- * type +-------------------------------------------------- + +-- | This is separate from 'TypeValidator' so that 'TypeValidator' can +-- be used to write 'JSONSchema.Draft4.Schema.Schema' without +-- messing up the 'FromJSON' instance of that data type. +newtype TypeContext + = TypeContext { _unTypeContext :: TypeValidator } + deriving (Eq, Show) + +instance FromJSON TypeContext where + parseJSON = withObject "TypeContext" $ \o -> + TypeContext <$> o .: "type" + +data TypeValidator + = TypeValidatorString SchemaType + | TypeValidatorArray (Set SchemaType) + deriving (Eq, Show) + +instance Semigroup TypeValidator where + (<>) x y + | isEmpty x = x + | isEmpty y = y + | x == y = x + | otherwise = TypeValidatorArray (setFromTypeValidator x + `Set.union` + setFromTypeValidator y) + where + isEmpty :: TypeValidator -> Bool + isEmpty (TypeValidatorString _) = False + isEmpty (TypeValidatorArray ts) = Set.null ts + + stimes = stimesIdempotent + +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 <$> arbitrary + , TypeValidatorArray <$> arbitrary + ] + +data SchemaType + = SchemaObject + | SchemaArray + | SchemaString + | SchemaNumber + | SchemaInteger + | SchemaBoolean + | SchemaNull + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + +instance FromJSON SchemaType where + parseJSON = genericParseJSON + defaultOptions + { constructorTagModifier = fmap toLower . drop 6 } + +instance ToJSON SchemaType where + toJSON = genericToJSON + defaultOptions + { constructorTagModifier = fmap toLower . drop 6 } + +instance Arbitrary SchemaType where + arbitrary = arbitraryBoundedEnum + +data TypeValidatorInvalid + = TypeValidatorInvalid TypeValidator Value + deriving (Eq, Show) + +typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid +typeVal (TypeContext tv) x + | Set.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 SchemaType + matches = Set.intersection okTypes (setFromTypeValidator tv) + + okTypes :: Set SchemaType + okTypes = + case x of + Null -> Set.singleton SchemaNull + (Array _) -> Set.singleton SchemaArray + (Bool _) -> Set.singleton SchemaBoolean + (Object _) -> Set.singleton SchemaObject + (String _) -> Set.singleton SchemaString + (Number y) -> + if SCI.isInteger y + then Set.fromList [SchemaNumber, SchemaInteger] + else Set.singleton SchemaNumber + +-- | Internal. +setFromTypeValidator :: TypeValidator -> Set SchemaType +setFromTypeValidator (TypeValidatorString t) = Set.singleton t +setFromTypeValidator (TypeValidatorArray ts) = ts + +-------------------------------------------------- +-- * allOf +-------------------------------------------------- + +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 + -> 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 +-------------------------------------------------- + +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 -> [err]) + -> AnyOf schema + -> Value + -> Maybe (AnyOfInvalid err) +anyOfVal f (AnyOf subSchemas) x + | any (null . snd) perhapsFailures = Nothing + | otherwise = AnyOfInvalid <$> 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 + +-------------------------------------------------- +-- * 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 (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) + +oneOfVal + :: forall err schema. ToJSON schema + => (schema -> Value -> [err]) + -> OneOf schema + -> Value + -> 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 + 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) + + otherPerhapsFailures :: [(JP.Index, Value, [err])] + otherPerhapsFailures = + zipWith + (\index schema -> (index, toJSON schema, f schema x)) + (JP.Index <$> [0..]) + otherSubSchemas + + 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 -> [err]) + -> NotValidator schema + -> Value + -> Maybe NotValidatorInvalid +notVal f (NotValidator schema) x = + case f schema x of + [] -> Just (NotValidatorInvalid (toJSON schema) x) + _ -> Nothing diff --git a/src/JSONSchema/Validator/Draft4/Array.hs b/src/JSONSchema/Validator/Draft4/Array.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Array.hs @@ -0,0 +1,225 @@ +module JSONSchema.Validator.Draft4.Array where + +import Import + +import qualified Data.List.NonEmpty as NE +import qualified Data.Vector as V +import qualified JSONPointer as JP + +import JSONSchema.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. +maxItemsVal :: MaxItems -> Vector Value -> Maybe MaxItemsInvalid +maxItemsVal a@(MaxItems n) xs + | n < 0 = Nothing + | 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. +minItemsVal :: MinItems -> Vector Value -> Maybe MinItemsInvalid +minItemsVal a@(MinItems n) xs + | n < 0 = Nothing + | V.length xs < n = Just (MinItemsInvalid a xs) + | otherwise = Nothing + +-------------------------------------------------- +-- * uniqueItems +-------------------------------------------------- + +newtype UniqueItems + = UniqueItems { _unUniqueItems :: Bool } + deriving (Eq, Show) + +instance FromJSON UniqueItems where + parseJSON = withObject "UniqueItems" $ \o -> + UniqueItems <$> o .: "uniqueItems" + +newtype UniqueItemsInvalid + = UniqueItemsInvalid (Vector Value) + deriving (Eq, Show) + +uniqueItemsVal :: UniqueItems -> Vector Value -> Maybe UniqueItemsInvalid +uniqueItemsVal (UniqueItems True) xs + | allUniqueValues xs = 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] + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (Items schema) where + parseJSON v = fmap ItemsObject (parseJSON v) + <|> fmap ItemsArray (parseJSON v) + +instance ToJSON schema => ToJSON (Items schema) where + toJSON (ItemsObject hm) = toJSON hm + toJSON (ItemsArray schemas) = toJSON schemas + +instance Arbitrary schema => Arbitrary (Items schema) where + arbitrary = oneof [ ItemsObject <$> arbitrary + , ItemsArray <$> arbitrary + ] + +data ItemsRelatedInvalid err + = IRInvalidItems (ItemsInvalid err) + | IRInvalidAdditional (AdditionalItemsInvalid err) + deriving (Eq, Show) + +data ItemsInvalid err + = ItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err)) + | ItemsArrayInvalid (NonEmpty (JP.Index, NonEmpty err)) + deriving (Eq, Show) + +-- | @"additionalItems"@ only matters if @"items"@ exists +-- and is a JSON Array. +itemsRelatedVal + :: forall err schema. + (schema -> Value -> [err]) + -> ItemsRelated schema + -> Vector Value + -> [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 + ] + +-- | 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 + indexed :: [(JP.Index, Value)] + indexed = zip (JP.Index <$> [0..]) (V.toList xs) + + validateElem + :: schema + -> (JP.Index, Value) + -> Maybe (JP.Index, NonEmpty err) + validateElem schema (index,x) = + (\v -> (index, v)) <$> NE.nonEmpty (f schema x) + +-------------------------------------------------- +-- * additionalItems +-------------------------------------------------- + +data AdditionalItems schema + = AdditionalBool Bool + | AdditionalObject schema + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (AdditionalItems schema) where + parseJSON v = fmap AdditionalBool (parseJSON v) + <|> fmap AdditionalObject (parseJSON v) + +instance ToJSON schema => ToJSON (AdditionalItems schema) where + toJSON (AdditionalBool b) = toJSON b + toJSON (AdditionalObject hm) = toJSON hm + +instance Arbitrary schema => Arbitrary (AdditionalItems schema) where + arbitrary = oneof [ AdditionalBool <$> arbitrary + , AdditionalObject <$> arbitrary + ] + +data AdditionalItemsInvalid err + = AdditionalItemsBoolInvalid (NonEmpty (JP.Index, Value)) + | AdditionalItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err)) + deriving (Eq, Show) + +-- | Internal. +-- +-- This is because 'itemsRelated' handles @"additionalItems"@ validation. +additionalItemsVal + :: forall err schema. + (schema -> Value -> [err]) + -> AdditionalItems schema + -> [(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) -> (\v -> (index, v)) + <$> NE.nonEmpty (f subSchema x)) + xs + in AdditionalItemsObjectInvalid <$> NE.nonEmpty res diff --git a/src/JSONSchema/Validator/Draft4/Number.hs b/src/JSONSchema/Validator/Draft4/Number.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Number.hs @@ -0,0 +1,83 @@ +module JSONSchema.Validator.Draft4.Number where + +import Import + +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. +multipleOfVal :: MultipleOf -> Scientific -> Maybe MultipleOfInvalid +multipleOfVal a@(MultipleOf n) x + | n <= 0 = Nothing + | 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 + = MaximumInvalid Maximum Scientific + deriving (Eq, Show) + +maximumVal + :: Maximum + -> Scientific + -> 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 + = MinimumInvalid Minimum Scientific + deriving (Eq, Show) + +minimumVal + :: Minimum + -> Scientific + -> 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/JSONSchema/Validator/Draft4/Object.hs b/src/JSONSchema/Validator/Draft4/Object.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Object.hs @@ -0,0 +1,182 @@ +module JSONSchema.Validator.Draft4.Object + ( module JSONSchema.Validator.Draft4.Object + , module JSONSchema.Validator.Draft4.Object.Properties + ) where + +import Import + +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T + +import JSONSchema.Validator.Draft4.Object.Properties +import JSONSchema.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. +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. +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 +-------------------------------------------------- + +-- | From the spec: +-- +-- > 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. +newtype Required + = Required { _unRequired :: Set Text } + deriving (Eq, Show) + +instance FromJSON Required where + parseJSON = withObject "Required" $ \o -> + Required <$> o .: "required" + +instance Arbitrary Required where + arbitrary = do + x <- arbitraryText -- Guarantee at least one element. + xs <- (fmap.fmap) T.pack arbitrary + pure . Required . Set.fromList $ x:xs + +data RequiredInvalid + = RequiredInvalid Required (Set Text) (HashMap Text Value) + deriving (Eq, Show) + +requiredVal :: Required -> HashMap Text Value -> Maybe RequiredInvalid +requiredVal r@(Required ts) x + | Set.null ts = Nothing + | Set.null leftovers = Nothing + | otherwise = Just (RequiredInvalid r leftovers x) + where + leftovers :: Set Text + leftovers = + Set.difference -- Items of the first set not in the second. + ts + (Set.fromList (HM.keys x)) + +-------------------------------------------------- +-- * 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) + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (Dependency schema) where + parseJSON v = fmap SchemaDependency (parseJSON v) + <|> fmap PropertyDependency (parseJSON v) + +instance ToJSON schema => ToJSON (Dependency schema) where + toJSON (SchemaDependency schema) = toJSON schema + toJSON (PropertyDependency ts) = toJSON ts + +instance Arbitrary schema => Arbitrary (Dependency schema) where + arbitrary = oneof [ SchemaDependency <$> arbitrary + , PropertyDependency <$> arbitrarySetOfText + ] + +data DependencyMemberInvalid err + = SchemaDepInvalid (NonEmpty err) + | PropertyDepInvalid (Set Text) (HashMap Text Value) + deriving (Eq, Show) + +newtype DependenciesInvalid err + = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err)) + deriving (Eq, Show) + +-- | From the spec: +-- +-- +-- > This keyword's value MUST be an object. +-- > Each value of this object MUST be either an object or an array. +-- > +-- > If the value is an object, it MUST be a valid JSON Schema. +-- > This is called a schema dependency. +-- > +-- > 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. +dependenciesVal + :: forall err schema. + (schema -> Value -> [err]) + -> DependenciesValidator schema + -> HashMap Text Value + -> 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/JSONSchema/Validator/Draft4/Object/Properties.hs b/src/JSONSchema/Validator/Draft4/Object/Properties.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Object/Properties.hs @@ -0,0 +1,209 @@ +module JSONSchema.Validator.Draft4.Object.Properties where + +import Import + +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 + +data PropertiesRelated schema = PropertiesRelated + { _propProperties :: Maybe (HashMap Text schema) + -- ^ 'Maybe' is used to distinguish whether the key is present or not. + , _propPattern :: Maybe (HashMap Text schema) + , _propAdditional :: Maybe (AdditionalProperties schema) + } deriving (Eq, Show) + +instance FromJSON schema => FromJSON (PropertiesRelated schema) where + parseJSON = withObject "PropertiesRelated" $ \o -> PropertiesRelated + <$> o .:! "properties" + <*> o .:! "patternProperties" + <*> o .:! "additionalProperties" + +emptyProperties :: PropertiesRelated schema +emptyProperties = PropertiesRelated + { _propProperties = Nothing + , _propPattern = Nothing + , _propAdditional = Nothing + } + +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 + ] + +-- | A glorified @type@ alias. +newtype Regex + = Regex { _unRegex :: Text } + deriving (Eq, Show, Generic) + +instance HA.Hashable Regex + +-- 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 APInvalid err + = APBoolInvalid (HashMap Text Value) + | APObjectInvalid (HashMap Text (NonEmpty err)) + deriving (Eq, Show) + +-- | First @"properties"@ and @"patternProperties"@ are run simultaneously +-- on the data, then @"additionalProperties"@ is run on the remainder. +propertiesRelatedVal + :: forall err schema. + (schema -> Value -> [err]) + -> PropertiesRelated schema + -> HashMap Text Value + -> 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 + propertiesHm :: HashMap Text schema + propertiesHm = fromMaybe mempty (_propProperties props) + + patHm :: HashMap Text schema + patHm = fromMaybe mempty (_propPattern props) + + 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 -> [err]) + -> HashMap Text schema + -> HashMap Text Value + -> (HashMap (Regex, JP.Key) [err], Remaining) +patternAndUnmatched f patPropertiesHm x = + (HM.foldlWithKey' runMatches mempty perhapsMatches, remaining) + where + -- @[(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 ([(Regex, schema)], Value) + -> Text + -> Value + -> HashMap Text ([(Regex, schema)], Value) + matchingSchemas subSchemas acc k v = + HM.insert k + (HM.foldlWithKey' (checkKey k) mempty subSchemas, v) + acc + + checkKey + :: Text + -> [(Regex, schema)] + -> Text + -> schema + -> [(Regex, schema)] + checkKey k acc r subSchema = + case RE.compileM (encodeUtf8 r) mempty of + Left _ -> acc + Right re -> if k RE.=~ re + then (Regex r, subSchema) : acc + else acc + + runMatches + :: HashMap (Regex, JP.Key) [err] + -> Text + -> ([(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 snd . HM.filter (null . fst) $ perhapsMatches + +-- Internal. +additionalProperties + :: forall err schema. + (schema -> Value -> [err]) + -> AdditionalProperties schema + -> Remaining + -> Maybe (APInvalid err) +additionalProperties f a x = + case a of + AdditionalPropertiesBool b -> + APBoolInvalid <$> additionalPropertiesBool b x + AdditionalPropertiesObject b -> + APObjectInvalid <$> additionalPropertiesObject f b x + +-- | Internal. +additionalPropertiesBool + :: Bool + -> 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 -> [err]) + -> schema + -> 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/JSONSchema/Validator/Draft4/String.hs b/src/JSONSchema/Validator/Draft4/String.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/String.hs @@ -0,0 +1,76 @@ +module JSONSchema.Validator.Draft4.String where + +import Import + +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) + +maxLengthVal :: MaxLength -> Text -> Maybe MaxLengthInvalid +maxLengthVal a@(MaxLength n) 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) + +minLengthVal :: MinLength -> Text -> Maybe MinLengthInvalid +minLengthVal a@(MinLength n) x + | T.length x < n = Just (MinLengthInvalid a x) + | otherwise = Nothing + +-------------------------------------------------- +-- * pattern +-------------------------------------------------- + +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 PatternNotRegex + Right re -> if input RE.=~ re + then Nothing + else Just (PatternInvalid a x) + where + input = T.unpack x -- workaround for a bug in pcre-light diff --git a/src/JSONSchema/Validator/Reference.hs b/src/JSONSchema/Validator/Reference.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Reference.hs @@ -0,0 +1,71 @@ +-- | JSON Reference is described here: +-- +-- +-- And is extended for JSON Schema here: +-- +module JSONSchema.Validator.Reference where + +import Import + +import qualified Data.Text as T +import System.FilePath (dropFileName, ()) + +data Scope schema = Scope + { _topLevelDocument :: schema + , _documentURI :: Maybe Text + , _currentBaseURI :: BaseURI + } deriving (Eq, Show) + +newtype BaseURI + = BaseURI { _unBaseURI :: Maybe Text } + deriving (Eq, Show) + +-- | TODO: no `type`s. +type URIAndFragment = (Maybe Text, Maybe Text) + +updateResolutionScope :: BaseURI -> Maybe Text -> BaseURI +updateResolutionScope base idKeyword = + case idKeyword of + Just t -> BaseURI . fst . baseAndFragment $ resolveScopeAgainst base t + Nothing -> base + +resolveReference :: BaseURI -> Text -> URIAndFragment +resolveReference base t = baseAndFragment (resolveScopeAgainst base t) + +-------------------------------------------------- +-- * Helpers +-------------------------------------------------- + +isRemoteReference :: Text -> Bool +isRemoteReference = T.isInfixOf "://" + +baseAndFragment :: Text -> URIAndFragment +baseAndFragment = f . T.splitOn "#" + where + f :: [Text] -> URIAndFragment + f [x] = (g x, Nothing) + f [x,y] = (g x, g y) + f _ = (Nothing, Nothing) + + g "" = Nothing + g x = Just x + +resolveScopeAgainst :: BaseURI -> Text -> Text +resolveScopeAgainst (BaseURI Nothing) t = t +resolveScopeAgainst (BaseURI (Just base)) t + | isRemoteReference t = t + | otherwise = smartAppend + where + -- There shouldn't be a fragment at the end of a scope URI, + -- but just in case a user leaves one in we want to be sure + -- to cut it off before appending. + smartAppend :: Text + smartAppend = + case baseAndFragment base of + (Just uri,_) -> + case T.unpack t of + -- We want "/foo" and "#/bar" to combine into + -- "/foo#/bar" not "/foo/#/bar". + '#':_ -> base <> t + _ -> T.pack (dropFileName (T.unpack uri) T.unpack t) + _ -> t diff --git a/src/JSONSchema/Validator/Types.hs b/src/JSONSchema/Validator/Types.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Types.hs @@ -0,0 +1,22 @@ +module JSONSchema.Validator.Types where + +import Import + +import Data.Profunctor (Profunctor(..)) + +data Validator schema val err = Validator + { _embedded :: val -> ([schema], [schema]) + -- ^ The first list is embedded schemas that validate the same piece + -- of data this schema validates (such as schemas embedded in 'allOf'). + -- The second is embedded schemas that validate a subset of that data + -- (such as the schemas embedded in 'items'). + -- + -- 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 -> [err] + } deriving Functor + +instance Profunctor (Validator schema) where + lmap f (Validator a b) = Validator (lmap f a) (lmap f b) + rmap = fmap diff --git a/src/JSONSchema/Validator/Utils.hs b/src/JSONSchema/Validator/Utils.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Utils.hs @@ -0,0 +1,119 @@ +module JSONSchema.Validator.Utils where + +import Import + +import Control.Monad (fail) +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Scientific (Scientific, fromFloatDigits) +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Vector as V + +-------------------------------------------------- +-- * QuickCheck +-------------------------------------------------- + +arbitraryText :: Gen Text +arbitraryText = T.pack <$> arbitrary + +arbitraryScientific :: Gen Scientific +arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary + +arbitraryPositiveScientific :: Gen Scientific +arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific) + . getPositive + <$> arbitrary + +newtype ArbitraryValue + = ArbitraryValue { _unArbitraryValue :: Value } + deriving (Eq, Show) + +instance Arbitrary ArbitraryValue where + arbitrary = ArbitraryValue <$> sized f + where + f :: Int -> Gen Value + f n | n <= 1 = oneof nonRecursive + | otherwise = oneof $ + fmap (Array . V.fromList) (traverse (const (f (n `div` 10))) + =<< (arbitrary :: Gen [()])) + : fmap (Object . HM.fromList) (traverse (const (g (n `div` 10))) + =<< (arbitrary :: Gen [()])) + : nonRecursive + + g :: Int -> Gen (Text, Value) + g n = (,) <$> arbitraryText <*> f n + + nonRecursive :: [Gen Value] + nonRecursive = + [ pure Null + , Bool <$> arbitrary + , String <$> arbitraryText + , Number <$> arbitraryScientific + ] + +arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a) +arbitraryHashMap = HM.fromList . fmap (first T.pack) <$> arbitrary + +arbitrarySetOfText :: Gen (Set Text) +arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary + +newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a } + +instance FromJSON a => FromJSON (NonEmpty' a) where + parseJSON v = do + xs <- parseJSON v + case NE.nonEmpty xs of + Nothing -> fail "Must have at least one item." + Just ne -> pure (NonEmpty' ne) + +instance ToJSON a => ToJSON (NonEmpty' a) where + toJSON = toJSON . NE.toList . _unNonEmpty' + +instance Arbitrary a => Arbitrary (NonEmpty' a) where + arbitrary = do + xs <- arbitrary + case NE.nonEmpty xs of + Nothing -> NonEmpty' . pure <$> arbitrary + Just ne -> pure (NonEmpty' ne) + +-------------------------------------------------- +-- * allUniqueValues +-------------------------------------------------- + +allUniqueValues :: (Foldable f, Functor f) => f Value -> Bool +allUniqueValues = allUnique . fmap OrdValue + +allUnique :: (Foldable f, Ord a) => f a -> Bool +allUnique xs = S.size (S.fromList (toList xs)) == length xs + +-- | OrdValue's Ord instance needs benchmarking, but it allows us to +-- use our 'allUnique' function instead of O(n^2) nub, so it's probably +-- worth it. +newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq + +instance Ord OrdValue where + (OrdValue Null) `compare` (OrdValue Null) = EQ + (OrdValue Null) `compare` _ = LT + _ `compare` (OrdValue Null) = GT + + (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y + (OrdValue (Bool _)) `compare` _ = LT + _ `compare` (OrdValue (Bool _)) = GT + + (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y + (OrdValue (Number _)) `compare` _ = LT + _ `compare` (OrdValue (Number _)) = GT + + (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y + (OrdValue (String _)) `compare` _ = LT + _ `compare` (OrdValue (String _)) = GT + + (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) = + (OrdValue <$> xs) `compare` (OrdValue <$> ys) + (OrdValue (Array _)) `compare` _ = LT + _ `compare` (OrdValue (Array _)) = GT + + (OrdValue (Object x)) `compare` (OrdValue (Object y)) = + HM.toList (OrdValue <$> x) `compare` HM.toList (OrdValue <$> y) diff --git a/test/JSONSchema/Validator/Draft4/StringSpec.hs b/test/JSONSchema/Validator/Draft4/StringSpec.hs new file mode 100644 --- /dev/null +++ b/test/JSONSchema/Validator/Draft4/StringSpec.hs @@ -0,0 +1,25 @@ +module JSONSchema.Validator.Draft4.StringSpec (spec) where + +import Protolude + +import Test.Hspec + +import JSONSchema.Validator.Draft4.String + +spec :: Spec +spec = do + describe "maxLengthVal" $ do + context "with 0" $ do + it "accepts the empty string" $ do + maxLengthVal (MaxLength 0) "" `shouldBe` Nothing + + it "rejects other strings" $ do + maxLengthVal (MaxLength 0) "foo" `shouldBe` Just (MaxLengthInvalid (MaxLength 0) "foo") + + describe "patternVal" $ do + it "matches a substring" $ do + patternVal (PatternValidator "baz") "foo bar baz" `shouldBe` Nothing + + context "with .*" $ do + it "matches the empty string (test for workaround for a bug in pcre-light)" $ do + patternVal (PatternValidator ".*") "" `shouldBe` Nothing diff --git a/test/Local.hs b/test/Local.hs --- a/test/Local.hs +++ b/test/Local.hs @@ -1,33 +1,29 @@ - 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 System.Timeout as TO +import qualified Data.List.NonEmpty as NE +import qualified System.Timeout as TO import Test.Hspec -import Test.QuickCheck (property) +import Test.QuickCheck (property) -import qualified Data.JsonSchema.Draft4 as D4 -import Data.JsonSchema.Fetch (ReferencedSchemas(..)) -import qualified Data.JsonSchema.Types as JT +import qualified JSONSchema.Draft4 as D4 +import qualified JSONSchema.Types as JT import qualified Local.Failure -import qualified Local.Validation import qualified Local.Reference +import qualified Local.Validation import Shared -- 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 () @@ -36,18 +32,16 @@ -- Language agnostic tests ts <- readSchemaTests dir - (\a -> not (isHTTPTest a || skipOptional a)) + (\a -> not (isHTTPTest a || skipTest a)) -- Custom supplements to the language agnostic tests - supplementTs <- readSchemaTests - supplementDir - (\a -> not (isHTTPTest a || skipOptional a)) + supplementTs <- readSchemaTests supplementDir (not . isHTTPTest) hspec $ do describe "Examples" exampleTests describe "QuickCheck" quickCheckTests describe "Failure" Local.Failure.spec - describe "Data.Validator.Reference" Local.Reference.spec + describe "JSONSchema.Validator.Reference" Local.Reference.spec describe "Supplementary validation tests written in Haskell" Local.Validation.spec @@ -68,27 +62,26 @@ Nothing -> expectationFailure "timeout expired" Just a -> pure a - validate :: D4.Schema -> SchemaTestCase -> Expectation + validate :: HasCallStack => D4.Schema -> SchemaTestCase -> Expectation validate s sc = do 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 :: HasCallStack => 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) - Nothing s (_scData sc) - traverse_ (checkPointer (_scData sc)) failures + schemaMap + (D4.SchemaWithURI s Nothing) + (_scData sc) assertResult sc failures quickCheckTests :: Spec @@ -101,5 +94,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,40 @@ - module Local.Failure where -import Prelude +import Protolude import Data.Aeson -import qualified Data.Aeson.Pointer as P -import Data.Monoid +import qualified Data.Vector as V +import qualified JSONPointer as JP import Test.Hspec -import Data.JsonSchema.Draft4 -import Data.JsonSchema.Draft4.Spec (validate) -import qualified Data.Validator.Draft4.Array as AR +import JSONSchema.Draft4 +import qualified JSONSchema.Draft4.Spec as Spec +import qualified JSONSchema.Validator.Draft4 as VAL 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 (VAL.ItemsArrayInvalid ( + pure ( JP.Index 0 + , pure (FailureUniqueItems (VAL.UniqueItemsInvalid + (V.fromList [Null, Null]) + )) + ) + )) ] where - failures = validate (ReferencedSchemas schema mempty) - sw (toJSON [[True, True]]) + failures :: [ValidatorFailure] + failures = Spec.specValidate mempty sw badData schema :: Schema schema = emptySchema - { _schemaItems = Just $ AR.ItemsArray + { _schemaItems = Just $ VAL.ItemsArray [emptySchema { _schemaUniqueItems = Just True }] } @@ -39,19 +44,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 (VAL.ItemsObjectInvalid ( + pure ( JP.Index 1 + , pure (FailureUniqueItems (VAL.UniqueItemsInvalid + (V.fromList [Null, Null]) + )) + ) + )) ] where - failures = validate (ReferencedSchemas schema mempty) - sw (toJSON [[True, True]]) + failures :: [ValidatorFailure] + failures = Spec.specValidate mempty sw badData schema :: Schema schema = emptySchema - { _schemaItems = Just $ AR.ItemsObject + { _schemaItems = Just $ VAL.ItemsObject (emptySchema { _schemaUniqueItems = Just True }) } @@ -60,3 +73,33 @@ { _swSchema = schema , _swURI = Nothing } + + badData :: Value + badData = toJSON [Null, toJSON [Null, Null]] + +loopRef :: Expectation +loopRef = + failures `shouldBe` + [ FailureRef (VAL.RefLoop + "#" + (VAL.VisitedSchemas [(Nothing, Nothing)]) + (Nothing, Nothing) + ) + ] + where + failures :: [ValidatorFailure] + failures = Spec.specValidate 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,35 +1,36 @@ - module Local.Reference where +import Protolude + import Test.Hspec -import Data.Validator.Reference +import JSONSchema.Validator.Reference spec :: Spec spec = do it "updateResolutionScope gives correct results" $ do - updateResolutionScope Nothing Nothing - `shouldBe` Nothing + updateResolutionScope (BaseURI Nothing) Nothing + `shouldBe` BaseURI Nothing - updateResolutionScope Nothing (Just "#") - `shouldBe` Nothing + updateResolutionScope (BaseURI Nothing) (Just "#") + `shouldBe` BaseURI Nothing - updateResolutionScope Nothing (Just "foo") - `shouldBe` Just "foo" + updateResolutionScope (BaseURI Nothing) (Just "foo") + `shouldBe` BaseURI (Just "foo") -- TODO: Normalize after updateResolutionScope: - updateResolutionScope (Just "/foo") (Just "./bar") - `shouldBe` Just "/./bar" + updateResolutionScope (BaseURI (Just "/foo")) (Just "./bar") + `shouldBe` BaseURI (Just "/./bar") it "resolveReference gives correct results" $ do - resolveReference (Just "/foo") "bar" + resolveReference (BaseURI (Just "/foo")) "bar" `shouldBe` (Just "/bar", Nothing) - resolveReference (Just "/foo/bar") "/baz" + resolveReference (BaseURI (Just "/foo/bar")) "/baz" `shouldBe` (Just "/baz", Nothing) - resolveReference Nothing "#/bar" + resolveReference (BaseURI Nothing) "#/bar" `shouldBe` (Nothing, Just "/bar") - resolveReference (Just "/foo") "#/bar" + resolveReference (BaseURI (Just "/foo")) "#/bar" `shouldBe` (Just "/foo", Just "/bar") diff --git a/test/Local/Validation.hs b/test/Local/Validation.hs --- a/test/Local/Validation.hs +++ b/test/Local/Validation.hs @@ -1,18 +1,16 @@ - module Local.Validation where -import Control.Applicative +import Protolude + import Data.Aeson -import qualified Data.Aeson as AE -import qualified Data.HashMap.Strict as HM -import Data.Monoid -import Data.Text (Text) +import qualified Data.Aeson as AE +import qualified Data.HashMap.Strict as HM +import Data.String (String) import Test.Hspec -import Data.JsonSchema.Draft4 -import qualified Data.JsonSchema.Types as JT - -import qualified AlternateSchema as AS +import qualified AlternateSchema as AS +import JSONSchema.Draft4 +import qualified JSONSchema.Types as JT spec :: Spec spec = do diff --git a/test/Remote.hs b/test/Remote.hs --- a/test/Remote.hs +++ b/test/Remote.hs @@ -1,25 +1,22 @@ - module Main where -import Control.Applicative -import Control.Concurrent.Async (withAsync) -import Data.Foldable (traverse_) -import qualified Data.List.NonEmpty as N -import Data.Monoid +import Protolude + +import Control.Concurrent.Async (withAsync) +import qualified Data.List.NonEmpty as NE import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) -import Network.Wai.Handler.Warp (run) +import qualified Network.Wai.Handler.Warp as Warp import Test.Hspec -import qualified Data.JsonSchema.Draft4 as D4 -import Data.JsonSchema.Fetch (ReferencedSchemas(..)) -import qualified Data.JsonSchema.Types as JT +import qualified JSONSchema.Draft4 as D4 +import qualified JSONSchema.Types as JT import Shared -- Examples import qualified AlternateSchema -dir :: String +dir :: FilePath dir = "JSON-Schema-Test-Suite/tests/draft4" main :: IO () @@ -36,26 +33,25 @@ 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) - Nothing s (_scData sc) - traverse_ (checkPointer (_scData sc)) failures + schemaMap + (D4.SchemaWithURI s Nothing) + (_scData sc) assertResult sc failures serve :: IO () -serve = run 1234 +serve = Warp.run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes" diff --git a/test/Shared.hs b/test/Shared.hs --- a/test/Shared.hs +++ b/test/Shared.hs @@ -1,29 +1,29 @@ -{-# 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 Data.Aeson.TH (fieldLabelModifier) +import qualified Data.ByteString as BS +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 +skipTest :: FilePath -> Bool +skipTest file = (file == "optional/format.json") + || (file == "optional/zeroTerminatedFloats.json") + || (file == "optional/ecmascript-regex.json") + +isHTTPTest :: FilePath -> Bool +isHTTPTest file = (file == "definitions.json") + || (file == "ref.json") + || (file == "refRemote.json") + -- Recursively return the contents of a directory -- (or return itself if given a file as an argument). -- @@ -47,38 +47,6 @@ 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 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 file = (file == "optional/format.json") - || (file == "optional/zeroTerminatedFloats.json") - data SchemaTest = SchemaTest { _stDescription :: Text , _stSchema :: Value @@ -104,9 +72,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,15 +82,15 @@ 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 - case eitherDecode jsonBS of + jsonBS <- BS.readFile fullPath + case eitherDecodeStrict jsonBS of 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 +106,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 :: (HasCallStack, Show err) => SchemaTestCase -> [err] -> Expectation assertResult sc failures | _scValid sc = assertValid sc failures | otherwise = assertInvalid sc failures -assertValid :: SchemaTestCase -> [D4.Failure] -> Expectation +assertValid :: (HasCallStack, Show err) => SchemaTestCase -> [err] -> Expectation assertValid _ [] = pure () assertValid sc failures = expectationFailure $ unlines @@ -156,7 +124,7 @@ , " Validation failures: " <> show failures ] -assertInvalid :: SchemaTestCase -> [D4.Failure] -> Expectation +assertInvalid :: HasCallStack => SchemaTestCase -> [err] -> Expectation assertInvalid sc [] = expectationFailure $ unlines [ " Validated invalid data" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-discover #-}