hjsonschema 1.5.0.1 → 1.6.0
raw patch · 31 files changed
+789/−288 lines, 31 files
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 +3/−3
- changelog.md +14/−0
- examples/AlternateSchema.hs +76/−42
- hjsonschema.cabal +1/−1
- src/Import.hs +9/−1
- src/JSONSchema/Draft4.hs +12/−18
- src/JSONSchema/Draft4/Spec.hs +59/−33
- src/JSONSchema/Fetch.hs +35/−55
- src/JSONSchema/Validator/Draft4.hs +13/−12
- src/JSONSchema/Validator/Draft4/Any.hs +180/−45
- src/JSONSchema/Validator/Draft4/Array.hs +1/−1
- src/JSONSchema/Validator/Draft4/Object.hs +1/−1
- src/JSONSchema/Validator/Draft4/Object/Properties.hs +1/−0
- src/JSONSchema/Validator/Reference.hs +27/−35
- src/JSONSchema/Validator/Utils.hs +0/−10
- test/Local.hs +3/−4
- test/Local/Failure.hs +3/−3
- test/Local/Reference.hs +12/−12
- test/Remote.hs +3/−4
- test/Shared.hs +3/−2
+ 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
@@ -40,7 +40,7 @@ ## Good Parts -+ Passes all the required tests in the [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite).++ Passes all the required tests in the [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite). NOTE: due to an issue with the test suite this isn't true at the moment, see [#175](https://github.com/json-schema-org/JSON-Schema-Test-Suite/issues/175). + Very modular, which should make it easy to support future versions of the specification. @@ -52,9 +52,9 @@ ## Vendoring -+ `JSON-Schema-Test-Suite` is vendored from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite).++ `JSON-Schema-Test-Suite` is vendored from commit # c1b12bf699f29a04b4286711c6e3bbfba66f21e5 [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).++ `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). ## Credits
changelog.md view
@@ -1,3 +1,17 @@+# 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.
examples/AlternateSchema.hs view
@@ -19,13 +19,15 @@ import JSONSchema.Draft4 (ValidatorFailure(..), metaSchemaBytes)-import JSONSchema.Fetch (ReferencedSchemas(..),- SchemaWithURI(..))+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 (updateResolutionScope)+import JSONSchema.Validator.Reference (BaseURI(..),+ Scope(..),+ updateResolutionScope) -------------------------------------------------- -- * Basic fetching tools@@ -45,22 +47,38 @@ 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 -> [ValidatorFailure]-validate rs = continueValidating rs (D4.VisitedSchemas [(Nothing, Nothing)])+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 =@@ -69,47 +87,57 @@ $ metaSchemaBytes checkSchema :: Schema -> [ValidatorFailure]-checkSchema = validate referenced Nothing metaSchema . Object . _unSchema+checkSchema = validate schemaMap (SchemaWithURI metaSchema Nothing)+ . Object+ . _unSchema where- referenced :: ReferencedSchemas Schema- referenced = ReferencedSchemas- metaSchema- (HM.singleton "http://json-schema.org/draft-04/schema"+ schemaMap :: URISchemaMap Schema+ schemaMap =+ URISchemaMap (HM.singleton "http://json-schema.org/draft-04/schema" metaSchema) -------------------------------------------------- -- * Spec -------------------------------------------------- -continueValidating- :: ReferencedSchemas Schema+validateSubschema+ :: URISchemaMap Schema -> D4.VisitedSchemas- -> Maybe Text+ -> Scope Schema -> Schema -> Value -> [ValidatorFailure]-continueValidating referenced visited mURI sc =- JT.validate (d4Spec referenced visited newScope) sc+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+ :: URISchemaMap Schema -> D4.VisitedSchemas- -> Maybe Text+ -> 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 referenced visited scope =- Spec+d4Spec schemaMap visited scope =+ Spec $+ [ dimap+ f+ FailureRef+ (D4.refValidator (FE.getReference schemaMap) updateScope+ valRef visited scope)+ ]++ <> fmap (lmap disableIfRefPresent) [ dimap f FailureMultipleOf D4.multipleOfValidator , dimap f FailureMaximum D4.maximumValidator , dimap f FailureMinimum D4.minimumValidator@@ -127,6 +155,7 @@ D4.IRInvalidItems e -> FailureItems e D4.IRInvalidAdditional e -> FailureAdditionalItems e) (D4.itemsRelatedValidator descend)+ , lmap f D4.definitionsEmbedded , dimap f FailureMaxProperties D4.maxPropertiesValidator , dimap f FailureMinProperties D4.minPropertiesValidator@@ -137,10 +166,6 @@ FailurePropertiesRelated (D4.propertiesRelatedValidator descend) - , dimap- f- FailureRef- (D4.refValidator visited scope (FE.getReference referenced) getRef) , dimap f FailureEnum D4.enumValidator , dimap f FailureType D4.typeValidator , dimap f FailureAllOf (D4.allOfValidator lateral)@@ -150,22 +175,31 @@ ] 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 referenced schema is fetched from,- -- this probably needs a 'newtype' wrapper.- getRef+ disableIfRefPresent :: Schema -> Schema+ disableIfRefPresent schema =+ case FE._fiRef draft4FetchInfo schema of+ Nothing -> schema+ Just _ -> Schema mempty++ updateScope :: BaseURI -> Schema -> BaseURI+ updateScope uri schema =+ updateResolutionScope uri (FE._fiId draft4FetchInfo schema)++ valRef :: D4.VisitedSchemas- -> Maybe Text+ -> Scope Schema -> Schema -> Value -> [ValidatorFailure]- getRef = continueValidating referenced+ valRef vis sc = JT.validate (d4Spec schemaMap vis sc) descend :: Schema -> Value -> [ValidatorFailure]- descend = continueValidating referenced mempty scope+ descend = validateSubschema schemaMap mempty scope lateral :: Schema -> Value -> [ValidatorFailure]- lateral = continueValidating referenced visited scope+ lateral = validateSubschema schemaMap visited scope
hjsonschema.cabal view
@@ -1,5 +1,5 @@ name: hjsonschema-version: 1.5.0.1+version: 1.6.0 synopsis: JSON Schema library homepage: https://github.com/seagreen/hjsonschema license: MIT
src/Import.hs view
@@ -1,5 +1,5 @@ -module Import (module Export) where+module Import (module Export, fromJSONEither) where import Protolude as Export @@ -10,3 +10,11 @@ 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
@@ -22,8 +22,7 @@ , ValidatorFailure(..) -- * Fetching tools- , ReferencedSchemas(..)- , FE.URISchemaMap(..)+ , URISchemaMap(..) , referencesViaHTTP , referencesViaFilesystem @@ -38,7 +37,6 @@ import Import -import Control.Arrow (left) import qualified Data.ByteString as BS import Data.FileEmbed (embedFile, makeRelativeToProject)@@ -52,8 +50,8 @@ import JSONSchema.Draft4.Schema (Schema) import qualified JSONSchema.Draft4.Schema as SC import qualified JSONSchema.Draft4.Spec as Spec-import JSONSchema.Fetch (ReferencedSchemas(..),- SchemaWithURI(..))+import JSONSchema.Fetch (SchemaWithURI(..),+ URISchemaMap(..)) import qualified JSONSchema.Fetch as FE data HTTPValidationFailure@@ -70,11 +68,11 @@ -> IO (Either HTTPValidationFailure ()) fetchHTTPAndValidate sw v = do res <- referencesViaHTTP sw- pure (g =<< f =<< left HVRequest res)+ pure (g =<< f =<< first HVRequest res) where f :: FE.URISchemaMap Schema -> Either HTTPValidationFailure (Value -> [ValidatorFailure])- f references = left HVSchema (checkSchema references sw)+ f references = first HVSchema (checkSchema references sw) g :: (Value -> [ValidatorFailure]) -> Either HTTPValidationFailure () g val = case NE.nonEmpty (val v) of@@ -100,11 +98,11 @@ -> IO (Either FilesystemValidationFailure ()) fetchFilesystemAndValidate sw v = do res <- referencesViaFilesystem sw- pure (g =<< f =<< left FVRead res)+ pure (g =<< f =<< first FVRead res) where f :: FE.URISchemaMap Schema -> Either FilesystemValidationFailure (Value -> [ValidatorFailure])- f references = left FVSchema (checkSchema references sw)+ f references = first FVSchema (checkSchema references sw) g :: (Value -> [ValidatorFailure]) -> Either FilesystemValidationFailure () g val = case NE.nonEmpty (val v) of@@ -143,10 +141,7 @@ checkSchema sm sw = case NE.nonEmpty failures of Just fs -> Left (SchemaInvalid fs)- Nothing -> Right (Spec.specValidate- (ReferencedSchemas (_swSchema sw)- (FE._unURISchemaMap sm))- sw)+ Nothing -> Right (Spec.specValidate sm sw) where failures :: [(Maybe Text, NonEmpty ValidatorFailure)] failures =@@ -169,12 +164,11 @@ -- (if so the returned list will be empty). schemaValidity :: Schema -> [ValidatorFailure] schemaValidity =- Spec.specValidate referenced (SchemaWithURI metaSchema Nothing) . toJSON+ Spec.specValidate schemaMap (SchemaWithURI metaSchema Nothing) . toJSON where- referenced :: ReferencedSchemas Schema- referenced = ReferencedSchemas- metaSchema- (HM.singleton "http://json-schema.org/draft-04/schema"+ schemaMap :: URISchemaMap Schema+ schemaMap =+ URISchemaMap (HM.singleton "http://json-schema.org/draft-04/schema" metaSchema) -- | Check that a set of referenced schemas are valid
src/JSONSchema/Draft4/Spec.hs view
@@ -7,47 +7,71 @@ import Data.Profunctor (Profunctor(..)) import JSONSchema.Draft4.Failure-import JSONSchema.Draft4.Schema (Schema(..))-import JSONSchema.Fetch (ReferencedSchemas(..),- SchemaWithURI(..))+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 (updateResolutionScope)+import JSONSchema.Validator.Reference (BaseURI(..),+ Scope(..),+ updateResolutionScope) +-- | 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 specValidate- :: ReferencedSchemas Schema+ :: URISchemaMap Schema -> SchemaWithURI Schema -> Value -> [ValidatorFailure]-specValidate rs =- continueValidating rs (VisitedSchemas [(Nothing, Nothing)])+specValidate schemaMap sw =+ JT.validate (d4Spec schemaMap visited scope) (_swSchema sw)+ where+ visited :: VisitedSchemas+ visited = VisitedSchemas [(Nothing, Nothing)] -continueValidating- :: ReferencedSchemas Schema+ scope :: Scope Schema+ scope = Scope+ { _topLevelDocument = _swSchema sw+ , _documentURI = _swURI sw+ , _currentBaseURI = updateResolutionScope (BaseURI (_swURI sw))+ (_schemaId (_swSchema sw))+ }++validateSubschema + :: URISchemaMap Schema -> VisitedSchemas- -> SchemaWithURI Schema+ -> Scope Schema+ -> Schema -> Value -> [ValidatorFailure]-continueValidating referenced visited sw =- JT.validate (d4Spec referenced visited currentScope)- (_swSchema sw)+validateSubschema schemaMap visited scope schema =+ JT.validate (d4Spec schemaMap visited newScope) schema where- currentScope :: Maybe Text- currentScope = updateResolutionScope- (_swURI sw)- (_schemaId (_swSchema sw))+ newScope :: Scope Schema+ newScope = scope+ { _currentBaseURI = updateResolutionScope (_currentBaseURI scope)+ (_schemaId schema)+ } d4Spec- :: ReferencedSchemas Schema+ :: URISchemaMap Schema -> VisitedSchemas- -> Maybe Text+ -> Scope Schema -> Spec Schema ValidatorFailure-d4Spec referenced visited scope = Spec+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)@@ -98,10 +122,6 @@ FailurePropertiesRelated (propertiesRelatedValidator descend) - , dimap- (\s -> Ref <$> _schemaRef s)- FailureRef- (refValidator visited scope (FE.getReference referenced) getRef) , dimap (fmap EnumValidator . _schemaEnum) FailureEnum enumValidator , dimap (fmap TypeContext . _schemaType) FailureType typeValidator , dimap (fmap AllOf . _schemaAllOf) FailureAllOf (allOfValidator lateral)@@ -110,19 +130,25 @@ , dimap (fmap NotValidator . _schemaNot) FailureNot (notValidator lateral) ] where- getRef+ 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- -> Maybe Text+ -> Scope Schema -> Schema -> Value -> [ValidatorFailure]- getRef newVisited newScope schema =- continueValidating referenced newVisited (SchemaWithURI schema newScope)+ valRef vis sc = JT.validate (d4Spec schemaMap vis sc) descend :: Schema -> Value -> [ValidatorFailure]- descend schema =- continueValidating referenced mempty (SchemaWithURI schema scope)+ descend = validateSubschema schemaMap mempty scope lateral :: Schema -> Value -> [ValidatorFailure]- lateral schema =- continueValidating referenced visited (SchemaWithURI schema scope)+ lateral = validateSubschema schemaMap visited scope
src/JSONSchema/Fetch.hs view
@@ -3,7 +3,6 @@ import Import -import Control.Arrow (left) import Control.Exception (IOException, catch) import Control.Monad (foldM) import qualified Data.ByteString as BS@@ -12,7 +11,8 @@ import qualified Data.Text as T import qualified Network.HTTP.Client as NC -import JSONSchema.Validator.Reference (resolveReference,+import JSONSchema.Validator.Reference (BaseURI(..),+ resolveReference, updateResolutionScope) --------------------------------------------------@@ -27,49 +27,22 @@ , _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 :: !(HashMap Text schema)- -- ^ Map of URIs to schemas.- } deriving (Eq, Show)- -- | Keys are URIs (without URI fragments). newtype URISchemaMap schema = URISchemaMap { _unURISchemaMap :: HashMap Text schema }- deriving (Eq, Show)+ deriving (Eq, Show, Monoid) +-- | A top-level schema along with its location. data SchemaWithURI schema = SchemaWithURI { _swSchema :: !schema , _swURI :: !(Maybe Text)- -- ^ This is the URI identifying the document containing the schema.+ -- ^ 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.-- -- 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) = HM.lookup t (_rsSchemaMap referenced)+getReference :: URISchemaMap schema -> Text -> Maybe schema+getReference schemaMap t = HM.lookup t (_unURISchemaMap schemaMap) -------------------------------------------------- -- * Fetch via HTTP@@ -90,7 +63,7 @@ referencesViaHTTP' info sw = do manager <- NC.newManager NC.defaultManagerSettings let f = referencesMethodAgnostic (getURL manager) info sw- catch (left HTTPParseFailure <$> f) handler+ catch (first HTTPParseFailure <$> f) handler where getURL :: NC.Manager -> Text -> IO BS.ByteString getURL man url = do@@ -116,7 +89,7 @@ => FetchInfo schema -> SchemaWithURI schema -> IO (Either FilesystemFailure (URISchemaMap schema))-referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler+referencesViaFilesystem' info sw = catch (first FSParseFailure <$> f) handler where f :: IO (Either Text (URISchemaMap schema)) f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw@@ -155,28 +128,34 @@ f :: Either Text (URISchemaMap schema) -> SchemaWithURI schema -> IO (Either Text (URISchemaMap schema))- f (Left e) _ = pure (Left e)- f (Right (URISchemaMap usm)) (SchemaWithURI schema mUri) =+ f (Left e) _ = pure (Left e)+ f (Right (URISchemaMap schemaMap)) (SchemaWithURI schema mURI) = case newRef of- Nothing -> pure (Right (URISchemaMap usm))+ Nothing -> pure (Right (URISchemaMap schemaMap)) Just uri -> do bts <- fetchRef uri case eitherDecodeStrict bts of- Left e -> pure . Left . T.pack $ e- Right schm -> getRecursiveReferences- fetchRef- info- (URISchemaMap (HM.insert uri schm usm))- (SchemaWithURI schm (Just uri))+ 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- | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema- = case HM.lookup uri usm of- Nothing -> Just uri- Just _ -> Nothing- | otherwise = Nothing+ 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@@ -184,11 +163,12 @@ FetchInfo schema -> SchemaWithURI schema -> [SchemaWithURI schema]-includeSubschemas info (SchemaWithURI schema mUri) =- SchemaWithURI schema mUri+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)+ let newScope = updateResolutionScope (BaseURI mURI) (_fiId info schema)+ updateScope s = SchemaWithURI s (_unBaseURI newScope)+ in updateScope <$> uncurry (<>) (_fiEmbedded info schema)
src/JSONSchema/Validator/Draft4.hs view
@@ -1,4 +1,7 @@ -- | 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@@ -9,16 +12,14 @@ import qualified Data.HashMap.Strict as HM import qualified Data.List.NonEmpty as NE-import Data.Maybe (catMaybes, maybe, maybeToList)-import Data.Text (Text) 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(..))-import JSONSchema.Validator.Utils (fromJSONEither) -- | For internal use. --@@ -75,6 +76,8 @@ 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)@@ -159,9 +162,6 @@ parseJSON = withObject "Definitions" $ \o -> Definitions <$> o .: "definitions" --- TODO: Add tests to the language agnostic test suite to--- make sure these schemas are embedded correctly--- (and do so for @"additionalItems"@ as well). definitionsEmbedded :: Validator schema@@ -180,15 +180,16 @@ refValidator :: (FromJSON schema, ToJSON schema)- => VisitedSchemas- -> Maybe Text- -> (Maybe Text -> Maybe schema)- -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])+ => (Text -> Maybe schema)+ -> (BaseURI -> schema -> BaseURI)+ -> (VisitedSchemas -> Scope schema -> schema -> Value -> [err])+ -> VisitedSchemas+ -> Scope schema -> Validator a (Maybe Ref) (RefInvalid err)-refValidator visited scope getRef f =+refValidator getRef updateScope f visited scope = Validator noEmbedded- (run (refVal visited scope getRef f))+ (run (refVal getRef updateScope f visited scope)) enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid enumValidator = Validator noEmbedded (run enumVal)
src/JSONSchema/Validator/Draft4/Any.hs view
@@ -1,19 +1,24 @@ module JSONSchema.Validator.Draft4.Any where -import Import+import Import hiding ((<>)) +import Data.Aeson.TH (constructorTagModifier)+import Data.Char (toLower) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NE import qualified Data.Scientific as SCI-import Data.Semigroup (Semigroup) -- for older GHCs+import Data.Semigroup import Data.Set (Set)-import qualified Data.Set as S+import qualified Data.Set as Set+import Data.Text.Encoding.Error (UnicodeException) import qualified JSONPointer as JP+import Network.HTTP.Types.URI (urlDecode) import qualified JSONSchema.Validator.Utils as UT-import JSONSchema.Validator.Reference (URIBaseAndFragment,- resolveFragment,+import JSONSchema.Validator.Reference (BaseURI(..),+ Scope(..),+ URIAndFragment, resolveReference) --------------------------------------------------@@ -39,43 +44,132 @@ -- Also note that ideally we would enforce in the type system that any -- failing references be dealt with before valididation. Then this could -- be removed entirely.- | RefPointerResolution Text- | RefLoop Text VisitedSchemas URIBaseAndFragment+ | 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 :: [URIBaseAndFragment] }+ = VisitedSchemas { _unVisited :: [URIAndFragment] } deriving (Eq, Show, Semigroup, Monoid) refVal :: forall err schema. (FromJSON schema, ToJSON schema)- => VisitedSchemas- -> Maybe Text- -> (Maybe Text -> Maybe schema)- -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])+ => (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 visited scope getRef f (Ref reference) x+refVal getRef updateScope val visited scope (Ref reference) x | (mURI, mFragment) `elem` _unVisited visited = Just (RefLoop reference visited (mURI, mFragment))- | otherwise =- case getRef mURI of- Nothing -> Just (RefResolution reference)- Just schema ->- case resolveFragment mFragment schema of- Nothing -> Just (RefPointerResolution reference)- Just s ->- let newVisited = (VisitedSchemas [(mURI, mFragment)]- <> visited)- errs = f newVisited mURI s x- in RefInvalid reference (toJSON schema)- <$> NE.nonEmpty errs+ | 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, mFragment) = resolveReference scope reference+ 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+ :: forall schema. (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.+ go :: (Value, BaseURI)+ -> JP.Token+ -> Either JSONPointerError (Value, BaseURI)+ go (lastVal, uri) tok = do+ v <- first ResolutionError (JP.resolveToken tok lastVal)+ case v of+ Array _ -> pure (v, uri)+ _ -> do+ -- PERFORMANCE: Avoid deserializing subschemas.+ schema <- first SubschemaDecodingError (fromJSONEither v)+ pure (v, updateScope uri schema)+ -------------------------------------------------- -- * enum --------------------------------------------------@@ -109,7 +203,10 @@ Just ne -> pure (EnumValidator ne) where toUnique :: [Value] -> [Value]- toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue+ toUnique = fmap UT._unOrdValue+ . Set.toList+ . Set.fromList+ . fmap UT.OrdValue data EnumInvalid = EnumInvalid EnumValidator Value@@ -137,10 +234,25 @@ TypeContext <$> o .: "type" data TypeValidator- = TypeValidatorString Text- | TypeValidatorArray (Set Text)+ = 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)@@ -150,40 +262,63 @@ toJSON (TypeValidatorArray ts) = toJSON ts instance Arbitrary TypeValidator where- arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText- , TypeValidatorArray <$> UT.arbitrarySetOfText+ 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- | S.null matches = Just (TypeValidatorInvalid tv x)- | otherwise = Nothing+ | 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 Text- matches = S.intersection okTypes (setFromTypeValidator tv)+ matches :: Set SchemaType+ matches = Set.intersection okTypes (setFromTypeValidator tv) - okTypes :: Set Text+ okTypes :: Set SchemaType okTypes = case x of- Null -> S.singleton "null"- (Array _) -> S.singleton "array"- (Bool _) -> S.singleton "boolean"- (Object _) -> S.singleton "object"- (String _) -> S.singleton "string"+ 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 S.fromList ["number", "integer"]- else S.singleton "number"+ then Set.fromList [SchemaNumber, SchemaInteger]+ else Set.singleton SchemaNumber -- | Internal.-setFromTypeValidator :: TypeValidator -> Set Text-setFromTypeValidator (TypeValidatorString t) = S.singleton t+setFromTypeValidator :: TypeValidator -> Set SchemaType+setFromTypeValidator (TypeValidatorString t) = Set.singleton t setFromTypeValidator (TypeValidatorArray ts) = ts --------------------------------------------------
src/JSONSchema/Validator/Draft4/Array.hs view
@@ -67,7 +67,7 @@ parseJSON = withObject "UniqueItems" $ \o -> UniqueItems <$> o .: "uniqueItems" -data UniqueItemsInvalid+newtype UniqueItemsInvalid = UniqueItemsInvalid (Vector Value) deriving (Eq, Show)
src/JSONSchema/Validator/Draft4/Object.hs view
@@ -145,7 +145,7 @@ | PropertyDepInvalid (Set Text) (HashMap Text Value) deriving (Eq, Show) -data DependenciesInvalid err+newtype DependenciesInvalid err = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err)) deriving (Eq, Show)
src/JSONSchema/Validator/Draft4/Object/Properties.hs view
@@ -12,6 +12,7 @@ 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)
src/JSONSchema/Validator/Reference.hs view
@@ -8,38 +8,30 @@ import Import -import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import qualified JSONPointer as JP-import Network.HTTP.Types.URI (urlDecode)-import System.FilePath ((</>), dropFileName)+import qualified Data.Text as T+import System.FilePath ((</>), dropFileName) --- | TODO: Replace these with actual URI data types.-type URIBase = Maybe Text-type URIBaseAndFragment = (Maybe Text, Maybe Text)+data Scope schema = Scope + { _topLevelDocument :: schema+ , _documentURI :: Maybe Text+ , _currentBaseURI :: BaseURI+ } deriving (Eq, Show) -updateResolutionScope :: URIBase -> Maybe Text -> URIBase-updateResolutionScope mScope idKeyword- | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t- | otherwise = mScope+newtype BaseURI+ = BaseURI { _unBaseURI :: Maybe Text }+ deriving (Eq, Show) -resolveReference :: URIBase -> Text -> URIBaseAndFragment-resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t+-- | TODO: no `type`s.+type URIAndFragment = (Maybe Text, Maybe Text) -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 (JP.unescape urlDecoded)- x <- either (const Nothing) Just (JP.resolve p (toJSON schema))- case fromJSON x of- Error _ -> Nothing- Success schema' -> Just schema'+updateResolutionScope :: BaseURI -> Maybe Text -> BaseURI+updateResolutionScope base idKeyword+ | Just t <- idKeyword = BaseURI . fst . baseAndFragment $ resolveScopeAgainst base t+ | otherwise = base +resolveReference :: BaseURI -> Text -> URIAndFragment+resolveReference base t = baseAndFragment (resolveScopeAgainst base t)+ -------------------------------------------------- -- * Helpers --------------------------------------------------@@ -47,10 +39,10 @@ isRemoteReference :: Text -> Bool isRemoteReference = T.isInfixOf "://" -baseAndFragment :: Text -> URIBaseAndFragment+baseAndFragment :: Text -> URIAndFragment baseAndFragment = f . T.splitOn "#" where- f :: [Text] -> URIBaseAndFragment+ f :: [Text] -> URIAndFragment f [x] = (g x, Nothing) f [x,y] = (g x, g y) f _ = (Nothing, Nothing)@@ -58,9 +50,9 @@ g "" = Nothing g x = Just x -resolveScopeAgainst :: Maybe Text -> Text -> Text-resolveScopeAgainst Nothing t = t-resolveScopeAgainst (Just scope) t+resolveScopeAgainst :: BaseURI -> Text -> Text+resolveScopeAgainst (BaseURI Nothing) t = t+resolveScopeAgainst (BaseURI (Just base)) t | isRemoteReference t = t | otherwise = smartAppend where@@ -69,11 +61,11 @@ -- to cut it off before appending. smartAppend :: Text smartAppend =- case baseAndFragment scope of- (Just base,_) ->+ 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 base) </> T.unpack t)+ _ -> T.pack (dropFileName (T.unpack uri) </> T.unpack t) _ -> t
src/JSONSchema/Validator/Utils.hs view
@@ -123,13 +123,3 @@ (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
test/Local.hs view
@@ -10,8 +10,6 @@ import Test.QuickCheck (property) import qualified JSONSchema.Draft4 as D4-import JSONSchema.Fetch (ReferencedSchemas(..),- URISchemaMap(..)) import qualified JSONSchema.Types as JT import qualified Local.Failure import qualified Local.Validation@@ -84,8 +82,9 @@ Left e -> panic ("Local.validateExample error: " <> show e) Right schemaMap -> do let failures = AlternateSchema.validate- (ReferencedSchemas s (_unURISchemaMap schemaMap))- Nothing s (_scData sc)+ schemaMap+ (D4.SchemaWithURI s Nothing)+ (_scData sc) assertResult sc failures quickCheckTests :: Spec
test/Local/Failure.hs view
@@ -31,7 +31,7 @@ ] where failures :: [ValidatorFailure]- failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData+ failures = Spec.specValidate mempty sw badData schema :: Schema schema = emptySchema@@ -61,7 +61,7 @@ ] where failures :: [ValidatorFailure]- failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData+ failures = Spec.specValidate mempty sw badData schema :: Schema schema = emptySchema@@ -89,7 +89,7 @@ ] where failures :: [ValidatorFailure]- failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData+ failures = Spec.specValidate mempty sw badData schema :: Schema schema = emptySchema
test/Local/Reference.hs view
@@ -10,28 +10,28 @@ 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/Remote.hs view
@@ -11,8 +11,6 @@ import Test.Hspec import qualified JSONSchema.Draft4 as D4-import JSONSchema.Fetch (ReferencedSchemas(..),- URISchemaMap(..)) import qualified JSONSchema.Types as JT import Shared @@ -48,8 +46,9 @@ Left e -> panic ("Remote.validateExample error: " <> show e) Right schemaMap -> do let failures = AlternateSchema.validate- (ReferencedSchemas s (_unURISchemaMap schemaMap))- Nothing s (_scData sc)+ schemaMap+ (D4.SchemaWithURI s Nothing)+ (_scData sc) assertResult sc failures serve :: IO ()
@@ -42,11 +42,12 @@ || (file == "ref.json") || (file == "refRemote.json") --- | We may never support the @"format"@ keywords, and--- are currently failing the zeroTerminatedFloats test.+-- | We may never support the @"format"@ keywords+-- and are currently failing the others listed here. skipOptional :: FilePath -> Bool skipOptional file = (file == "optional/format.json") || (file == "optional/zeroTerminatedFloats.json")+ || (file == "optional/ecmascript-regex.json") data SchemaTest = SchemaTest { _stDescription :: Text