hjsonschema 1.2.0.2 → 1.10.0
raw patch · 61 files changed
Files
- JSON-Schema-Test-Suite/remotes/name.json +11/−0
- JSON-Schema-Test-Suite/tests/draft4/additionalItems.json +6/−1
- JSON-Schema-Test-Suite/tests/draft4/items.json +32/−0
- JSON-Schema-Test-Suite/tests/draft4/maximum.json +5/−0
- JSON-Schema-Test-Suite/tests/draft4/minimum.json +5/−0
- JSON-Schema-Test-Suite/tests/draft4/optional/ecmascript-regex.json +13/−0
- JSON-Schema-Test-Suite/tests/draft4/optional/format.json +2/−2
- JSON-Schema-Test-Suite/tests/draft4/ref.json +139/−0
- JSON-Schema-Test-Suite/tests/draft4/refRemote.json +100/−3
- JSON-Schema-Test-Suite/tests/draft4/required.json +5/−0
- JSON-Schema-Test-Suite/tests/draft4/type.json +15/−0
- README.md +12/−48
- changelog.md +213/−0
- changelog.txt +0/−146
- examples/AlternateSchema.hs +142/−102
- examples/Full.hs +0/−40
- examples/Simple.hs +26/−26
- examples/TwoStep.hs +48/−0
- hjsonschema.cabal +97/−49
- src/Data/JsonSchema/Draft4.hs +0/−183
- src/Data/JsonSchema/Draft4/Failure.hs +0/−123
- src/Data/JsonSchema/Draft4/Schema.hs +0/−338
- src/Data/JsonSchema/Draft4/Spec.hs +0/−137
- src/Data/JsonSchema/Fetch.hs +0/−194
- src/Data/JsonSchema/Types.hs +0/−38
- src/Data/Validator/Draft4.hs +0/−550
- src/Data/Validator/Draft4/Any.hs +0/−236
- src/Data/Validator/Draft4/Array.hs +0/−184
- src/Data/Validator/Draft4/Number.hs +0/−65
- src/Data/Validator/Draft4/Object.hs +0/−157
- src/Data/Validator/Draft4/Object/Properties.hs +0/−214
- src/Data/Validator/Draft4/String.hs +0/−45
- src/Data/Validator/Failure.hs +0/−49
- src/Data/Validator/Reference.hs +0/−79
- src/Data/Validator/Types.hs +0/−27
- src/Data/Validator/Utils.hs +0/−137
- src/Import.hs +16/−9
- src/JSONSchema/Draft4.hs +186/−0
- src/JSONSchema/Draft4/Failure.hs +58/−0
- src/JSONSchema/Draft4/Schema.hs +341/−0
- src/JSONSchema/Draft4/Spec.hs +150/−0
- src/JSONSchema/Fetch.hs +175/−0
- src/JSONSchema/Types.hs +35/−0
- src/JSONSchema/Validator/Draft4.hs +242/−0
- src/JSONSchema/Validator/Draft4/Any.hs +509/−0
- src/JSONSchema/Validator/Draft4/Array.hs +225/−0
- src/JSONSchema/Validator/Draft4/Number.hs +83/−0
- src/JSONSchema/Validator/Draft4/Object.hs +182/−0
- src/JSONSchema/Validator/Draft4/Object/Properties.hs +209/−0
- src/JSONSchema/Validator/Draft4/String.hs +76/−0
- src/JSONSchema/Validator/Reference.hs +71/−0
- src/JSONSchema/Validator/Types.hs +22/−0
- src/JSONSchema/Validator/Utils.hs +119/−0
- test/JSONSchema/Validator/Draft4/StringSpec.hs +25/−0
- test/Local.hs +23/−30
- test/Local/Failure.hs +60/−17
- test/Local/Reference.hs +15/−14
- test/Local/Validation.hs +8/−10
- test/Remote.hs +15/−19
- test/Shared.hs +30/−62
- test/Spec.hs +1/−0
+ JSON-Schema-Test-Suite/remotes/name.json view
@@ -0,0 +1,11 @@+{+ "definitions": {+ "orNull": {+ "anyOf": [+ {"type": "null"},+ {"$ref": "#"}+ ]+ }+ },+ "type": "string"+}
JSON-Schema-Test-Suite/tests/draft4/additionalItems.json view
@@ -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 },
JSON-Schema-Test-Suite/tests/draft4/items.json view
@@ -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 } ] }
JSON-Schema-Test-Suite/tests/draft4/maximum.json view
@@ -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
JSON-Schema-Test-Suite/tests/draft4/minimum.json view
@@ -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
+ JSON-Schema-Test-Suite/tests/draft4/optional/ecmascript-regex.json view
@@ -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+ }+ ]+ }+]
JSON-Schema-Test-Suite/tests/draft4/optional/format.json view
@@ -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",
JSON-Schema-Test-Suite/tests/draft4/ref.json view
@@ -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 } ]
JSON-Schema-Test-Suite/tests/draft4/refRemote.json view
@@ -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 } ]
JSON-Schema-Test-Suite/tests/draft4/required.json view
@@ -18,6 +18,11 @@ "description": "non-present required property is invalid", "data": {"bar": 1}, "valid": false+ },+ {+ "description": "ignores non-objects",+ "data": 12,+ "valid": true } ] },
JSON-Schema-Test-Suite/tests/draft4/type.json view
@@ -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 }, {
README.md view
@@ -1,61 +1,25 @@-+# 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).
+ changelog.md view
@@ -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.
− changelog.txt
@@ -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.
examples/AlternateSchema.hs view
@@ -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
− examples/Full.hs
@@ -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."
examples/Simple.hs view
@@ -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."
+ examples/TwoStep.hs view
@@ -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."
hjsonschema.cabal view
@@ -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
− src/Data/JsonSchema/Draft4.hs
@@ -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
− src/Data/JsonSchema/Draft4/Failure.hs
@@ -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
− src/Data/JsonSchema/Draft4/Schema.hs
@@ -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- }
− src/Data/JsonSchema/Draft4/Spec.hs
@@ -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)
− src/Data/JsonSchema/Fetch.hs
@@ -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)
− src/Data/JsonSchema/Types.hs
@@ -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)
− src/Data/Validator/Draft4.hs
@@ -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))
− src/Data/Validator/Draft4/Any.hs
@@ -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:--- <http://json-schema.org/latest/json-schema-validation.html#anchor76>------ > 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
− src/Data/Validator/Draft4/Array.hs
@@ -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
− src/Data/Validator/Draft4/Number.hs
@@ -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)
− src/Data/Validator/Draft4/Object.hs
@@ -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:--- <http://json-schema.org/latest/json-schema-validation.html#anchor70>------ > 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
− src/Data/Validator/Draft4/Object/Properties.hs
@@ -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
− src/Data/Validator/Draft4/String.hs
@@ -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))
− src/Data/Validator/Failure.hs
@@ -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 }
− src/Data/Validator/Reference.hs
@@ -1,79 +0,0 @@--- | JSON Reference is described here:--- <http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03>------ And is extended for JSON Schema here:--- <http://json-schema.org/latest/json-schema-core.html#anchor26>--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
− src/Data/Validator/Types.hs
@@ -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
− src/Data/Validator/Utils.hs
@@ -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
src/Import.hs view
@@ -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
+ src/JSONSchema/Draft4.hs view
@@ -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
+ src/JSONSchema/Draft4/Failure.hs view
@@ -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)
+ src/JSONSchema/Draft4/Schema.hs view
@@ -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+ }
+ src/JSONSchema/Draft4/Spec.hs view
@@ -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
+ src/JSONSchema/Fetch.hs view
@@ -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)
+ src/JSONSchema/Types.hs view
@@ -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)
+ src/JSONSchema/Validator/Draft4.hs view
@@ -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))
+ src/JSONSchema/Validator/Draft4/Any.hs view
@@ -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:+-- <http://json-schema.org/latest/json-schema-validation.html#anchor76>+--+-- > 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
+ src/JSONSchema/Validator/Draft4/Array.hs view
@@ -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
+ src/JSONSchema/Validator/Draft4/Number.hs view
@@ -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
+ src/JSONSchema/Validator/Draft4/Object.hs view
@@ -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:+-- <http://json-schema.org/latest/json-schema-validation.html#anchor70>+--+-- > 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
+ src/JSONSchema/Validator/Draft4/Object/Properties.hs view
@@ -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
+ src/JSONSchema/Validator/Draft4/String.hs view
@@ -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
+ src/JSONSchema/Validator/Reference.hs view
@@ -0,0 +1,71 @@+-- | JSON Reference is described here:+-- <http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03>+--+-- And is extended for JSON Schema here:+-- <http://json-schema.org/latest/json-schema-core.html#anchor26>+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
+ src/JSONSchema/Validator/Types.hs view
@@ -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
+ src/JSONSchema/Validator/Utils.hs view
@@ -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)
+ test/JSONSchema/Validator/Draft4/StringSpec.hs view
@@ -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
test/Local.hs view
@@ -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
test/Local/Failure.hs view
@@ -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]]
test/Local/Reference.hs view
@@ -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")
test/Local/Validation.hs view
@@ -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
test/Remote.hs view
@@ -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"
@@ -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"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-discover #-}