hjsonschema 1.2.0.2 → 1.3.0.0

raw patch · 31 files changed

+1376/−1535 lines, 31 filesdep +hashabledep +protoludedep ~aesondep ~hjsonpointerPVP ok

version bump matches the API change (PVP)

Dependencies added: hashable, protolude

Dependency ranges changed: aeson, hjsonpointer

API changes (from Hackage documentation)

Files

• README.md +8/−4
• changelog.txt +28/−33
• examples/AlternateSchema.hs +80/−67
• examples/Full.hs +0/−40
• examples/Simple.hs +21/−20
• examples/TwoStep.hs +49/−0
• hjsonschema.cabal +16/−9
• src/Data/JsonSchema/Draft4.hs +58/−46
• src/Data/JsonSchema/Draft4/Failure.hs +47/−111
• src/Data/JsonSchema/Draft4/Schema.hs +24/−20
• src/Data/JsonSchema/Draft4/Spec.hs +68/−77
• src/Data/JsonSchema/Fetch.hs +26/−26
• src/Data/JsonSchema/Types.hs +4/−6
• src/Data/Validator/Draft4.hs +137/−445
• src/Data/Validator/Draft4/Any.hs +219/−105
• src/Data/Validator/Draft4/Array.hs +138/−98
• src/Data/Validator/Draft4/Number.hs +51/−32
• src/Data/Validator/Draft4/Object.hs +88/−66
• src/Data/Validator/Draft4/Object/Properties.hs +144/−149
• src/Data/Validator/Draft4/String.hs +50/−16
• src/Data/Validator/Failure.hs +0/−49
• src/Data/Validator/Reference.hs +4/−4
• src/Data/Validator/Types.hs +3/−7
• src/Data/Validator/Utils.hs +1/−3
• src/Import.hs +6/−6
• test/Local.hs +13/−16
• test/Local/Failure.hs +59/−15
• test/Local/Reference.hs +2/−0
• test/Local/Validation.hs +3/−3
• test/Remote.hs +10/−12
• test/Shared.hs +19/−50

@@ -1,13 +1,17 @@ ![hjsonschema logo](./logo.jpg) -A Haskell implementation of the current [JSON Schema](http://json-schema.org/) specification (Draft 4).+A Haskell implementation of the most commonly used [JSON Schema](http://json-schema.org/) specification ([Draft 4](https://github.com/json-schema-org/json-schema-spec/wiki/Specification-Links#draft-4)).  [Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema) -Requires [pcre](http://www.pcre.org/) (`pkgs.pcre` in Nixpkgs).+# Notes -NOTE: Schemas with circular references can cause infinite loops. hjsonschema does loop detection but it may not be solid yet -- please open an issue if you find a situation where it fails.++ As of 2017 [json-schema-org](https://github.com/json-schema-org/json-schema-spec) has begun releasing new drafts of the standard. Once this work stabilizes `hjsonschema` will add coverage for the latest draft. ++ Requires [pcre](http://www.pcre.org/) (`pkgs.pcre` in Nixpkgs).+++ Schemas with circular references can cause infinite loops. hjsonschema does loop detection but it may not be solid yet -- please open an issue if you find a situation where it fails.+ # Example  See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Simple.hs).@@ -46,7 +50,7 @@  + Currently doesn't support the optional `"format"` validators. -## Notes+## Vendoring  + `JSON-Schema-Test-Suite` is vendored from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite). 

@@ -1,3 +1,17 @@+# 1.3.0.0+++ Rewrite failure messages.++We used to return a list of every failed validator, no matter how far it was buried within subschemas of the original schema.++Now we return a tree of failure messages, so that if the first schema had only three validators, then no more than three top level failures will be returned.+++ Move the code to parse each validator from JSON from `Data.Validator.Draft4` into the validators' modules themselves.+++ Switch from Prelude to Protolude.+++ Switch `Data.JsonSchema.Fetch` from lazy to strict bytestrings.+ # 1.2.0.2  + Bump hspec.@@ -8,8 +22,7 @@  # 1.2.0.0 -+ Return `AdditionalPropertiesObject` error correctly (was mistakenly-returning `AdditionalItemsObject` instead.++ Return `AdditionalPropertiesObject` error correctly (was mistakenly returning `AdditionalItemsObject` instead. + Don't silence errors resulting from subschemas of "anyOf" or "oneOf".  # 1.1.0.1@@ -18,33 +31,23 @@  # 1.1.0.0 -+ Rename `schemaForSchemas` to `metaSchema` and `schemaForSchemasBytes` to-`metaSchemaBytes`.++ Rename `schemaForSchemas` to `metaSchema` and `schemaForSchemasBytes` to `metaSchemaBytes`.  # 1.0.0.0  ## Bug fixes: -+ Fix JSON Pointer bug. Pointers were being built in reverse order and so were-totally invalid.-+ Use `.:!` instead of `.:?` to parse the draft 4 schema. The only way to omit-optional fields in JSON Schema Draft 4 is to omit them entirely, `"null"`-can't be used for this.++ Fix JSON Pointer bug. Pointers were being built in reverse order and so were totally invalid.++ Use `.:!` instead of `.:?` to parse the draft 4 schema. The only way to omit optional fields in JSON Schema Draft 4 is to omit them entirely, `"null"` can't be used for this.  ## API Changes:  + Add referenced schema loop detection. + Add a new `referencesValidity` function.-+ `checkSchema` now checks referenced schema's validity in addition to the-starting schema's validity. This change bubbles up to the one-step validation-functions as well.-+ Switch most of the fetching code to use `URISchemaMap` instead of-`ReferencedSchemas`. It didn't need to know about the more complicated data-type.-+ Rething failure related names. Change `Invalid` to `Failure`, add a new-`Invalid` type alias which is only used for final results.-+ Failures now include the failing part of the data as well as a JSON Pointer to-it, so you don't have to worry about resolving the pointer.++ `checkSchema` now checks referenced schema's validity in addition to the starting schema's validity. This change bubbles up to the one-step validation functions as well.++ Switch most of the fetching code to use `URISchemaMap` instead of `ReferencedSchemas`. It didn't need to know about the more complicated data type.++ Rething failure related names. Change `Invalid` to `Failure`, add a new `Invalid` type alias which is only used for final results.++ Failures now include the failing part of the data as well as a JSON Pointer to it, so you don't have to worry about resolving the pointer.  ## Fundamental Changes: @@ -73,8 +76,7 @@  + Rewrite fetching internals. + Fix reference resolution defects, add more tests.-+ Switch to a Perl style regex library, which is closer to ECMAScript regexes-than the previous Posix style one.++ Switch to a Perl style regex library, which is closer to ECMAScript regexes than the previous Posix style one. + Add one-step validation functions ('fetchFilesystemAndValidate' and 'fetchHTTPAndValidate'). + Alias the validation failure type exported by 'Data.JsonSchema.Draft4' to 'Invalid', change its field names.@@ -90,11 +92,8 @@  + Improve scope updating and resolving. + Rename RawSchema's _rsObject field to _rsData.-+ Make RawSchema's _rsURI field a Maybe. This way schemas without a starting-URI can say so explicitly with Nothing instead of with "".-+ Rename Graph to SchemaGraph. Declare it with data instead of type. Give it a-field referencing the starting schema. This field is used to find the curent-schema if no URI is in scope and a self-referencing $ref is found (e.g. "#").++ Make RawSchema's _rsURI field a Maybe. This way schemas without a starting URI can say so explicitly with Nothing instead of with "".++ Rename Graph to SchemaGraph. Declare it with data instead of type. Give it a field referencing the starting schema. This field is used to find the curent schema if no URI is in scope and a self-referencing $ref is found (e.g. "#"). + Change the order of the last two arguments to fetchReferencedSchemas.  # 0.7.1@@ -105,13 +104,10 @@  Change error type from Text to ValidationFailure. -Revert the 0.6 changes to validate. Also switch from Vector-to list. Validate is now:+Revert the 0.6 changes to validate. Also switch from Vector to list. Validate is now:   Schema err -> Value -> [ValidationFailure err] -Add fetchReferencedSchemas', which lets the user provide their-own MonadIO function to be used when fetching schemas. This lets-them do things like only fetch schemas from particular domains.+Add fetchReferencedSchemas', which lets the user provide their own MonadIO function to be used when fetching schemas. This lets them do things like only fetch schemas from particular domains.  # 0.6 @@ -131,8 +127,7 @@  # 0.5.2 -+ Add convenience function for validating and compiling draft 4 schemas-simultaneously.++ Add convenience function for validating and compiling draft 4 schemas simultaneously.  # 0.5.1 

@@ -5,35 +5,29 @@ -- to copy this module instead of the 'Data.JsonSchema.Draft4'. While it's -- less convenient to write schemas in Haskell without a record type, you -- can get the implementation finished with far fewer lines of code.------ Note that this module imports the the failure sum type and failure related--- helper functions from the library. If you're implementing a custom schema--- with different error types from JSON Schema Draft 4 you'll have to make--- your own.  module AlternateSchema where -import           Data.Aeson                     (FromJSON(..), Value(..),-                                                 decode)-import qualified Data.Aeson                     as AE-import qualified Data.ByteString.Lazy           as LBS-import qualified Data.HashMap.Strict            as HM-import           Data.Maybe                     (fromMaybe)-import           Data.Monoid-import           Data.Profunctor                (Profunctor (..))-import           Data.Text                      (Text)+import           Protolude -import           Data.JsonSchema.Draft4         (metaSchemaBytes)-import           Data.JsonSchema.Draft4.Failure-import           Data.JsonSchema.Fetch          (ReferencedSchemas(..),-                                                 SchemaWithURI(..))-import qualified Data.JsonSchema.Fetch          as FE-import           Data.JsonSchema.Types          (Schema(..), Spec(..))-import qualified Data.JsonSchema.Types          as JT-import qualified Data.Validator.Draft4          as D4-import qualified Data.Validator.Draft4.Any      as AN-import           Data.Validator.Reference       (updateResolutionScope)+import           Data.Aeson               (FromJSON(..), Value(..),+                                           decode)+import qualified Data.Aeson               as AE+import qualified Data.ByteString.Lazy     as LBS+import qualified Data.HashMap.Strict      as HM+import           Data.Maybe               (fromMaybe)+import           Data.Profunctor          (Profunctor (..)) +import           Data.JsonSchema.Draft4   (ValidatorFailure(..),+                                           metaSchemaBytes)+import           Data.JsonSchema.Fetch    (ReferencedSchemas(..),+                                           SchemaWithURI(..))+import qualified Data.JsonSchema.Fetch    as FE+import           Data.JsonSchema.Types    (Schema(..), Spec(..))+import qualified Data.JsonSchema.Types    as JT+import qualified Data.Validator.Draft4    as D4+import           Data.Validator.Reference (updateResolutionScope)+ -------------------------------------------------- -- * Basic fetching tools --------------------------------------------------@@ -44,12 +38,13 @@ referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo  draft4FetchInfo :: FE.FetchInfo Schema-draft4FetchInfo = FE.FetchInfo embedded (get "id") (get "$ref")+draft4FetchInfo = FE.FetchInfo embedded (lookup "id") (lookup "$ref")   where-    get :: Text -> Schema -> Maybe Text-    get k (Schema s) = case HM.lookup k s of-                           Just (String t) -> Just t-                           _ -> Nothing+    lookup :: Text -> Schema -> Maybe Text+    lookup k (Schema s) =+        case HM.lookup k s of+            Just (String t) -> Just t+            _               -> Nothing  embedded :: Schema -> ([Schema], [Schema]) embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s@@ -63,26 +58,26 @@     -> Maybe Text     -> Schema     -> Value-    -> [Failure]-validate rs = continueValidating rs (AN.VisitedSchemas [(Nothing, Nothing)])+    -> [ValidatorFailure]+validate rs = continueValidating rs (D4.VisitedSchemas [(Nothing, Nothing)])  -- A schema for schemas themselves, using @src/draft4.json@ which is loaded -- at compile time. metaSchema :: Schema metaSchema =-      fromMaybe (error "Schema decode failed (this should never happen)")+      fromMaybe (panic "Schema decode failed (this should never happen)")     . decode     . LBS.fromStrict     $ metaSchemaBytes -checkSchema :: Schema -> [Failure]+checkSchema :: Schema -> [ValidatorFailure] checkSchema = validate referenced Nothing metaSchema . Object . _unSchema   where     referenced :: ReferencedSchemas Schema     referenced = ReferencedSchemas                      metaSchema                      (HM.singleton "http://json-schema.org/draft-04/schema"-                         metaSchema)+                                   metaSchema)  -------------------------------------------------- -- * Spec@@ -90,11 +85,11 @@  continueValidating     :: ReferencedSchemas Schema-    -> AN.VisitedSchemas+    -> D4.VisitedSchemas     -> Maybe Text     -> Schema     -> Value-    -> [Failure]+    -> [ValidatorFailure] continueValidating referenced visited mURI sc =     JT.validate (d4Spec referenced visited newScope) sc   where@@ -108,39 +103,52 @@  d4Spec     :: ReferencedSchemas Schema-    -> AN.VisitedSchemas+    -> D4.VisitedSchemas     -> Maybe Text-    -> Spec Schema ValidatorChain+    -> Spec Schema ValidatorFailure+       -- ^ Here we reuses 'ValidatorFailure' from+       -- 'Data.JsonSchema.Draft4.Failure'. If your validators have different+       -- failure possibilities you'll need to create your own validator+       -- failure type. d4Spec referenced visited scope =     Spec-        [ dimap f (const MultipleOf) D4.multipleOf-        , dimap f maxE D4.maximumVal-        , dimap f minE D4.minimumVal+        [ dimap f FailureMultipleOf D4.multipleOfValidator+        , dimap f FailureMaximum D4.maximumValidator+        , dimap f FailureMinimum D4.minimumValidator -        , dimap f (const MaxLength) D4.maxLength-        , dimap f (const MinLength) D4.minLength-        , dimap f (const PatternValidator) D4.patternVal+        , dimap f FailureMaxLength D4.maxLengthValidator+        , dimap f FailureMinLength D4.minLengthValidator+        , dimap f FailurePattern D4.patternValidator -        , dimap f (const MaxItems) D4.maxItems-        , dimap f (const MinItems) D4.minItems-        , dimap f (const UniqueItems) D4.uniqueItems-        , dimap f itemsE (D4.items descend)+        , dimap f FailureMaxItems D4.maxItemsValidator+        , dimap f FailureMinItems D4.minItemsValidator+        , dimap f FailureUniqueItems D4.uniqueItemsValidator+        , dimap+            (fromMaybe D4.emptyItems . f)+            (\err -> case err of+                         D4.IRInvalidItems e      -> FailureItems e+                         D4.IRInvalidAdditional e -> FailureAdditionalItems e)+            (D4.itemsRelatedValidator descend) -        , dimap f (const MaxProperties) D4.maxProperties-        , dimap f (const MinProperties) D4.minProperties-        , dimap f (const Required) D4.required-        , dimap f depsE (D4.dependencies descend)-        , dimap f propE (D4.properties descend)-        , dimap f patPropE (D4.patternProperties descend)-        , dimap f addPropE (D4.additionalProperties descend)+        , dimap f FailureMaxProperties D4.maxPropertiesValidator+        , dimap f FailureMinProperties D4.minPropertiesValidator+        , dimap f FailureRequired D4.requiredValidator+        , dimap f FailureDependencies (D4.dependenciesValidator descend)+        , dimap+            (fromMaybe D4.emptyProperties . f)+            FailurePropertiesRelated+            (D4.propertiesRelatedValidator descend) -        , dimap f refE (D4.ref visited scope (FE.getReference referenced) refVal)-        , dimap f (const Enum) D4.enumVal-        , dimap f (const TypeValidator) D4.typeVal-        , dimap f AllOf (D4.allOf lateral)-        , dimap f AnyOf (D4.anyOf lateral)-        , dimap f oneOfE (D4.oneOf lateral)-        , dimap f (const NotValidator) (D4.notVal lateral)+        , dimap+            f+            FailureRef+            (D4.refValidator visited scope (FE.getReference referenced) getRef)+        , dimap f FailureEnum D4.enumValidator+        , dimap f FailureType D4.typeValidator+        , dimap f FailureAllOf (D4.allOfValidator lateral)+        , dimap f FailureAnyOf (D4.anyOfValidator lateral)+        , dimap f FailureOneOf (D4.oneOfValidator lateral)+        , dimap f FailureNot (D4.notValidator lateral)         ]   where     f :: FromJSON a => Schema -> Maybe a@@ -148,13 +156,18 @@                        AE.Error _   -> Nothing                        AE.Success b -> Just b -    -- 'Maybe Text' is the URI the refernced schema is fetch from,+    -- 'Maybe Text' is the URI the referenced schema is fetched from,     -- this probably needs a 'newtype' wrapper.-    refVal :: AN.VisitedSchemas -> Maybe Text -> Schema -> Value -> [Failure]-    refVal = continueValidating referenced+    getRef+        :: D4.VisitedSchemas+        -> Maybe Text+        -> Schema+        -> Value+        -> [ValidatorFailure]+    getRef = continueValidating referenced -    descend :: Schema -> Value -> [Failure]+    descend :: Schema -> Value -> [ValidatorFailure]     descend = continueValidating referenced mempty scope -    lateral :: Schema -> Value -> [Failure]+    lateral :: Schema -> Value -> [ValidatorFailure]     lateral = continueValidating referenced visited scope

@@ -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."

@@ -1,10 +1,8 @@--- | Demonstrate 'D4.fetchFilesystemAndValidate'.------ To fetch schemas using HTTP instead of from the filesystem use--- 'D4.fetchHTTPAndValidate'.  module Simple where +import           Protolude+ import           Data.Aeson             (Value(..), decode, toJSON) import qualified Data.ByteString.Lazy   as LBS import qualified Data.List.NonEmpty     as NE@@ -13,25 +11,28 @@ import qualified Data.JsonSchema.Draft4 as D4  badData :: Value-badData = toJSON (["foo", "foo"] :: [String])+badData = toJSON [True, True]  example :: IO () example = do--    -- Get the starting schema.-    bts <- LBS.readFile "./examples/json/start.json"-    let schema = fromMaybe (error "Invalid schema JSON.") (decode bts)-        schemaWithURI = D4.SchemaWithURI schema (Just "./examples/json/start.json")+    bts <- LBS.readFile "./examples/json/unique.json"+    let schema = fromMaybe (panic "Invalid schema JSON.") (decode bts)+        schemaWithURI = D4.SchemaWithURI+                            schema+                            Nothing -- This would be the URI of the schema+                                    -- if it had one. It's used if the schema+                                    -- has relative references to other+                                    -- schemas. -    -- Fetch any referenced schemas, check that our original schema itself-    -- is valid, and validate the data.-    res <- D4.fetchFilesystemAndValidate schemaWithURI badData+    -- Fetch any referenced schemas over HTTP, check that our original schema+    -- itself is valid, and validate the data.+    res <- D4.fetchHTTPAndValidate schemaWithURI badData     case res of-        Right ()                  -> error "We validated bad data."-        Left (D4.FVRead _)        -> error ("Error fetching a referenced schema"-                                            ++ " (either during IO or parsing).")-        Left (D4.FVSchema _)      -> error "Our 'schema' itself was invalid."-        Left (D4.FVData failures) ->+        Right ()                  -> panic "We validated bad data."+        Left (D4.HVRequest _)     -> panic ("Error fetching a referenced schema"+                                            <> " (either during IO or parsing).")+        Left (D4.HVSchema _)      -> panic "Our 'schema' itself was invalid."+        Left (D4.HVData (D4.Invalid _ _ failures)) ->             case NE.toList failures of-                [D4.Failure (D4.Ref D4.UniqueItems) _ _ _] -> return () -- Success.-                _ -> error "Got more invalidation reasons than we expected."+                [D4.FailureUniqueItems _] -> pure () -- Success.+                _ -> panic "We got a different failure than expected."

@@ -0,0 +1,49 @@+-- | Differences from @examples/Simple.hs@:+--+-- * We demonstrate how to do the validation step without IO by first+-- getting the references with 'D4.referencesViaFilesystem'.+--+-- * This shows how to write the starting schema in Haskell instead+-- of parsing it from JSON.+--+-- * This schema references other schemas. Previously we used+-- 'fetchHTTPAndValidate' which fetched references over HTTP (though it+-- didn't matter because the last schema didn't actually have any).+-- This time we need to get them from the filesystem.++module TwoStep where++import           Protolude++import           Data.Aeson             (Value (..), toJSON)+import qualified Data.List.NonEmpty     as NE++import qualified Data.JsonSchema.Draft4 as D4+import qualified Data.Validator.Draft4  as VAL++schema :: D4.Schema+schema = D4.emptySchema { D4._schemaRef = Just "./unique.json" }++schemaContext :: D4.SchemaWithURI D4.Schema+schemaContext = D4.SchemaWithURI+    { D4._swSchema = schema+    , D4._swURI    = Just "./examples/json/start.json"+    }++badData :: Value+badData = toJSON [True, True]++example :: IO ()+example = do+    res <- D4.referencesViaFilesystem schemaContext+    let references = case res of+                         Left _  -> panic "Couldn't fetch referenced schemas."+                         Right a -> a+        validate = case D4.checkSchema references schemaContext of+                       Left _  -> panic "Not a valid schema."+                       Right f -> f+    case validate badData of+        [] -> panic "We validated bad data."+        [D4.FailureRef (VAL.RefInvalid _ _ (D4.FailureUniqueItems _ NE.:|[])) ] ->+            pure () -- Success+        _ -> panic "We got a different failure than expected."

@@ -1,5 +1,5 @@ name:               hjsonschema-version:            1.2.0.2+version:            1.3.0.0 synopsis:           JSON Schema library homepage:           https://github.com/seagreen/hjsonschema license:            MIT@@ -26,15 +26,15 @@     src   default-language: Haskell2010   default-extensions:+    DeriveFunctor+    DeriveGeneric+    GeneralizedNewtypeDeriving     NoImplicitPrelude     OverloadedStrings     ScopedTypeVariables+    TupleSections   if impl(ghc >= 8)     default-extensions: StrictData-  other-extensions:-    DeriveFunctor-    GeneralizedNewtypeDeriving-    TemplateHaskell   ghc-options:     -Wall   exposed-modules:@@ -50,7 +50,6 @@     , Data.Validator.Draft4.Number     , Data.Validator.Draft4.Object     , Data.Validator.Draft4.String-    , Data.Validator.Failure     , Data.Validator.Reference     , Data.Validator.Types     , Data.Validator.Utils@@ -60,17 +59,19 @@   build-depends:       base                 >= 4.7    && < 4.10     -- 0.11 is for `.:!`:-    , aeson                >= 0.11   && < 1.1+    , aeson                >= 0.11   && < 1.2     , bytestring           >= 0.10   && < 0.11     , containers           >= 0.5    && < 0.6     , file-embed           >= 0.0.8  && < 0.1     , filepath             >= 1.3    && < 1.5-    , hjsonpointer         >= 0.3    && < 1.1+    , hashable             >= 1.2    && < 1.3+    , hjsonpointer         >= 1.1    && < 1.2     -- 0.4.30 is for parseUrlThrow:     , http-client          >= 0.4.30 && < 0.6     , http-types           >= 0.8    && < 0.10     , pcre-heavy           >= 1.0    && < 1.1     , profunctors          >= 5.0    && < 5.3+    , protolude            >= 0.1.10 && < 1.2     , QuickCheck           >= 2.8    && < 2.10     , scientific           >= 0.3    && < 0.4     , semigroups           >= 0.18   && < 0.19@@ -89,6 +90,8 @@     -Wall     -fno-warn-orphans   default-extensions:+    DeriveGeneric+    NoImplicitPrelude     OverloadedStrings     ScopedTypeVariables   other-modules:@@ -98,8 +101,8 @@     , Shared     -- from ./examples:     , AlternateSchema-    , Full     , Simple+    , TwoStep   build-depends:       base     , aeson@@ -108,6 +111,7 @@     , hjsonpointer     , hjsonschema     , profunctors+    , protolude     , semigroups     , text     , QuickCheck@@ -129,6 +133,8 @@     -Wall     -fno-warn-orphans   default-extensions:+    DeriveGeneric+    NoImplicitPrelude     OverloadedStrings     ScopedTypeVariables   other-modules:@@ -144,6 +150,7 @@     , hjsonpointer     , hjsonschema     , profunctors+    , protolude     , semigroups     , text     , unordered-containers

@@ -10,7 +10,7 @@     , fetchHTTPAndValidate     , HTTPValidationFailure(..)     , FE.HTTPFailure(..)-    , InvalidSchema+    , SchemaInvalid(..)        -- * One-step validation (getting references from the filesystem)     , fetchFilesystemAndValidate@@ -18,13 +18,12 @@     , FE.FilesystemFailure(..)        -- * Validation failure-    , Invalid-    , Failure-    , FR.Fail(..)-    , ValidatorChain(..)+    , Invalid(..)+    , ValidatorFailure(..)        -- * Fetching tools     , ReferencedSchemas(..)+    , FE.URISchemaMap(..)     , referencesViaHTTP     , referencesViaFilesystem @@ -38,9 +37,8 @@     ) where  import           Import-import           Prelude -import           Control.Arrow                   (first, left)+import           Control.Arrow                   (left) import qualified Data.ByteString                 as BS import           Data.FileEmbed                  (embedFile,                                                   makeRelativeToProject)@@ -48,25 +46,24 @@ import qualified Data.List.NonEmpty              as NE import           Data.Maybe                      (fromMaybe) -import           Data.JsonSchema.Draft4.Failure  (Failure, Invalid,-                                                  InvalidSchema,-                                                  ValidatorChain(..))+import           Data.JsonSchema.Draft4.Failure  (Invalid(..),+                                                  SchemaInvalid(..),+                                                  ValidatorFailure(..)) import           Data.JsonSchema.Draft4.Schema   (Schema) import qualified Data.JsonSchema.Draft4.Schema   as SC import qualified Data.JsonSchema.Draft4.Spec     as Spec import           Data.JsonSchema.Fetch           (ReferencedSchemas(..),                                                   SchemaWithURI(..)) import qualified Data.JsonSchema.Fetch           as FE-import qualified Data.Validator.Failure          as FR  data HTTPValidationFailure     = HVRequest FE.HTTPFailure-    | HVSchema  InvalidSchema+    | HVSchema  SchemaInvalid     | HVData    Invalid     deriving Show  -- | Fetch recursively referenced schemas over HTTP, check that both the--- original and referenced schemas are valid, and then validate data.+-- original and referenced schemas are valid, then validate then data. fetchHTTPAndValidate     :: SchemaWithURI Schema     -> Value@@ -76,23 +73,27 @@     pure (g =<< f =<< left HVRequest res)   where     f :: FE.URISchemaMap Schema-      -> Either HTTPValidationFailure (Value -> [Failure])+      -> Either HTTPValidationFailure (Value -> [ValidatorFailure])     f references = left HVSchema (checkSchema references sw) -    g :: (Value -> [Failure]) -> Either HTTPValidationFailure ()-    g validate = case NE.nonEmpty (validate v) of-                     Nothing       -> Right ()-                     Just failures -> Left (HVData failures)+    g :: (Value -> [ValidatorFailure]) -> Either HTTPValidationFailure ()+    g val = case NE.nonEmpty (val v) of+                Nothing       -> Right ()+                Just failures -> Left (HVData Invalid+                                     { _invalidSchema   = _swSchema sw+                                     , _invalidInstance = v+                                     , _invalidFailures = failures+                                     })  data FilesystemValidationFailure     = FVRead   FE.FilesystemFailure-    | FVSchema InvalidSchema+    | FVSchema SchemaInvalid     | FVData   Invalid     deriving (Show, Eq) --- | Fetch recursively referenced schemas from the filesystem, check that--- both the original and referenced schemas are valid, and then--- validate data.+-- | Fetch recursively referenced schemas from the filesystem, check+-- that both the original and referenced schemas are valid, then validate+-- the data. fetchFilesystemAndValidate     :: SchemaWithURI Schema     -> Value@@ -102,13 +103,17 @@     pure (g =<< f =<< left FVRead res)   where     f :: FE.URISchemaMap Schema-      -> Either FilesystemValidationFailure (Value -> [Failure])+      -> Either FilesystemValidationFailure (Value -> [ValidatorFailure])     f references = left FVSchema (checkSchema references sw) -    g :: (Value -> [Failure]) -> Either FilesystemValidationFailure ()-    g validate = case NE.nonEmpty (validate v) of-                     Nothing      -> Right ()-                     Just invalid -> Left (FVData invalid)+    g :: (Value -> [ValidatorFailure]) -> Either FilesystemValidationFailure ()+    g val = case NE.nonEmpty (val v) of+                Nothing      -> Right ()+                Just invalid -> Left (FVData Invalid+                                    { _invalidSchema   = _swSchema sw+                                    , _invalidInstance = v+                                    , _invalidFailures = invalid+                                    })  -- | An instance of 'Data.JsonSchema.Fetch.FetchInfo' specialized for -- JSON Schema Draft 4.@@ -128,27 +133,31 @@     -> IO (Either FE.FilesystemFailure (FE.URISchemaMap Schema)) referencesViaFilesystem = FE.referencesViaFilesystem' draft4FetchInfo --- | A helper function.------ Checks if a schema and a set of referenced schemas are valid.+-- | Checks if a schema and a set of referenced schemas are valid. -- -- Return a function to validate data. checkSchema     :: FE.URISchemaMap Schema     -> SchemaWithURI Schema-    -> Either InvalidSchema (Value -> [Failure])+    -> Either SchemaInvalid (Value -> [ValidatorFailure]) checkSchema sm sw =     case NE.nonEmpty failures of-        Nothing -> Right (Spec.validate (ReferencedSchemas (_swSchema sw) sm) sw)-        Just fs -> Left fs+        Just fs -> Left (SchemaInvalid fs)+        Nothing -> Right (Spec.specValidate+                             (ReferencedSchemas (_swSchema sw)+                                                (FE._unURISchemaMap sm))+                             sw)   where-    failures :: [(Maybe Text, Failure)]-    failures = ((\v -> (Nothing, v)) <$> schemaValidity (_swSchema sw))-            <> (first Just <$> referencesValidity sm)+    failures :: [(Maybe Text, NonEmpty ValidatorFailure)]+    failures =+        let refFailures = first Just <$> referencesValidity sm+        in case NE.nonEmpty (schemaValidity (_swSchema sw)) of+                     Nothing   -> refFailures+                     Just errs -> (Nothing,errs) : refFailures  metaSchema :: Schema metaSchema =-      fromMaybe (error "Schema decode failed (this should never happen)")+      fromMaybe (panic "Schema decode failed (this should never happen)")     . decodeStrict     $ metaSchemaBytes @@ -158,26 +167,29 @@  -- | Check that a schema itself is valid -- (if so the returned list will be empty).-schemaValidity :: Schema -> [Failure]+schemaValidity :: Schema -> [ValidatorFailure] schemaValidity =-    Spec.validate referenced (SchemaWithURI metaSchema Nothing) . toJSON+    Spec.specValidate referenced (SchemaWithURI metaSchema Nothing) . toJSON   where     referenced :: ReferencedSchemas Schema     referenced = ReferencedSchemas                      metaSchema                      (HM.singleton "http://json-schema.org/draft-04/schema"-                         metaSchema)+                                   metaSchema)  -- | Check that a set of referenced schemas are valid -- (if so the returned list will be empty). referencesValidity   :: FE.URISchemaMap Schema-  -> [(Text, Failure)]-  -- ^ The first value in the tuple is the URI of a referenced schema.-referencesValidity = HM.foldlWithKey' f mempty+  -> [(Text, NonEmpty ValidatorFailure)]+  -- ^ The first item of the tuple is the URI of a schema, the second+  -- is that schema's validation errors.+referencesValidity = HM.foldlWithKey' f mempty . FE._unURISchemaMap   where-    f :: [(Text, Failure)]+    f :: [(Text, NonEmpty ValidatorFailure)]       -> Text       -> Schema-      -> [(Text, Failure)]-    f acc k v = ((\a -> (k,a)) <$> schemaValidity v) <> acc+      -> [(Text, NonEmpty ValidatorFailure)]+    f acc k v = case NE.nonEmpty (schemaValidity v) of+                    Nothing   -> acc+                    Just errs -> (k,errs) : acc

@@ -1,123 +1,59 @@  module Data.JsonSchema.Draft4.Failure where -import           Prelude--import           Data.List.NonEmpty            (NonEmpty)-import           Data.Text                     (Text)--import qualified Data.Validator.Draft4.Any    as AN-import qualified Data.Validator.Draft4.Array  as AR-import qualified Data.Validator.Draft4.Number as NU-import qualified Data.Validator.Draft4.Object as OB-import qualified Data.Validator.Failure       as FR---- | A description of why a schema (or one of its reference) is itself--- invalid.------ 'Nothing' indicates the starting schema. 'Just' indicates a referenced--- schema -- the contents of the 'Just' is the schema's URI.------ NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of defining--- this, but then we lose the guarantee that there's at least one key.-type InvalidSchema = NonEmpty (Maybe Text, Failure)+import           Import -type Invalid = NonEmpty Failure+import           Data.JsonSchema.Draft4.Schema (Schema)+import qualified Data.Validator.Draft4         as D4 -type Failure = FR.Fail ValidatorChain+-- | Used to report an entire instance being invalidated, as opposed+-- to the failure of a single validator.+data Invalid = Invalid+    { _invalidSchema   :: Schema+    , _invalidInstance :: Value+    , _invalidFailures :: NonEmpty ValidatorFailure+    } deriving (Eq, Show) --- | Distinguish all the different possible causes of failure for--- Draft 4 validation.-data ValidatorChain-    = MultipleOf-    | Maximum-    | ExclusiveMaximum-    | Minimum-    | ExclusiveMinimum+data ValidatorFailure+    = FailureMultipleOf D4.MultipleOfInvalid+    | FailureMaximum    D4.MaximumInvalid+    | FailureMinimum    D4.MinimumInvalid -    | MaxLength-    | MinLength-    | PatternValidator+    | FailureMaxLength D4.MaxLengthInvalid+    | FailureMinLength D4.MinLengthInvalid+    | FailurePattern   D4.PatternInvalid -    | MaxItems-    | MinItems-    | UniqueItems-    | Items ValidatorChain-    | AdditionalItemsBool-    | AdditionalItemsObject ValidatorChain+    | FailureMaxItems        D4.MaxItemsInvalid+    | FailureMinItems        D4.MinItemsInvalid+    | FailureUniqueItems     D4.UniqueItemsInvalid+    | FailureItems           (D4.ItemsInvalid ValidatorFailure)+    | FailureAdditionalItems (D4.AdditionalItemsInvalid ValidatorFailure) -    | MaxProperties-    | MinProperties-    | Required-    | SchemaDependency ValidatorChain-    | PropertyDependency-    | Properties ValidatorChain-    | PatternProperties ValidatorChain-    | AdditionalPropertiesBool-    | AdditionalPropertiesObject ValidatorChain+    | FailureMaxProperties     D4.MaxPropertiesInvalid+    | FailureMinProperties     D4.MinPropertiesInvalid+    | FailureRequired          ()+    | FailureDependencies      (D4.DependenciesInvalid ValidatorFailure)+    | FailurePropertiesRelated (D4.PropertiesRelatedInvalid ValidatorFailure) -    | RefResolution-      -- ^ Indicates a reference that failed to resolve.-      ---      -- NOTE: The language agnostic test suite doesn't specify if this should-      -- cause a validation error or should allow data to pass. We choose to-      -- return a validation error.-      ---      -- Also note that ideally we would enforce in the type system that any-      -- failing references be dealt with before valididation. Then this could-      -- be removed entirely.-    | RefLoop-    | Ref ValidatorChain-    | Enum-    | TypeValidator-    | AllOf ValidatorChain-    | AnyOf ValidatorChain-    | OneOfTooManySuccesses-    | OneOfNoSuccesses ValidatorChain-    | NotValidator+    | FailureRef   (D4.RefInvalid ValidatorFailure)+    | FailureEnum  D4.EnumInvalid+    | FailureType  D4.TypeValidatorInvalid+    | FailureAllOf (D4.AllOfInvalid ValidatorFailure)+    | FailureAnyOf (D4.AnyOfInvalid ValidatorFailure)+    | FailureOneOf (D4.OneOfInvalid ValidatorFailure)+    | FailureNot   D4.NotValidatorInvalid     deriving (Eq, Show) -maxE :: NU.MaximumInvalid -> ValidatorChain-maxE NU.Maximum          = Maximum-maxE NU.ExclusiveMaximum = ExclusiveMaximum--minE :: NU.MinimumInvalid -> ValidatorChain-minE NU.Minimum          = Minimum-minE NU.ExclusiveMinimum = ExclusiveMinimum--itemsE :: AR.ItemsInvalid ValidatorChain -> ValidatorChain-itemsE (AR.Items err)                        = Items err-itemsE AR.AdditionalItemsBoolInvalid         = AdditionalItemsBool-itemsE (AR.AdditionalItemsObjectInvalid err) = AdditionalItemsObject err--depsE :: OB.DependencyInvalid ValidatorChain -> ValidatorChain-depsE (OB.SchemaDependencyInvalid err) = SchemaDependency err-depsE OB.PropertyDependencyInvalid     = PropertyDependency--propE :: OB.PropertiesInvalid ValidatorChain -> ValidatorChain-propE (OB.PropertiesInvalid err)   = Properties err-propE (OB.PropPatternInvalid err)  = PatternProperties err-propE (OB.PropAdditionalInvalid a) =-    case a of-        OB.APBoolInvalid       -> AdditionalPropertiesBool-        OB.APObjectInvalid err -> AdditionalPropertiesObject err--patPropE :: OB.PatternPropertiesInvalid ValidatorChain -> ValidatorChain-patPropE (OB.PPInvalid err) = PatternProperties err-patPropE (OB.PPAdditionalPropertiesInvalid a)   =-    case a of-        OB.APBoolInvalid       -> AdditionalPropertiesBool-        OB.APObjectInvalid err -> AdditionalPropertiesObject err--addPropE :: OB.AdditionalPropertiesInvalid ValidatorChain -> ValidatorChain-addPropE OB.APBoolInvalid         = AdditionalPropertiesBool-addPropE (OB.APObjectInvalid err) = AdditionalPropertiesObject err--refE :: AN.RefInvalid ValidatorChain -> ValidatorChain-refE AN.RefResolution    = RefResolution-refE AN.RefLoop          = RefLoop-refE (AN.RefInvalid err) = Ref err--oneOfE :: AN.OneOfInvalid ValidatorChain -> ValidatorChain-oneOfE AN.TooManySuccesses  = OneOfTooManySuccesses-oneOfE (AN.NoSuccesses err) = OneOfNoSuccesses err+-- | A description of why a schema (or one of its reference) is itself+-- invalid.+--+-- 'Nothing' indicates the starting schema. 'Just' indicates a referenced+-- schema. The contents of the 'Just' is the schema's URI.+--+-- NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of+-- defining this, but then we lose the guarantee that there's at least+-- one key.+newtype SchemaInvalid+    = SchemaInvalid {+        _unSchemaInvalid :: NonEmpty (Maybe Text, NonEmpty ValidatorFailure) }+    deriving (Eq, Show)

@@ -1,17 +1,16 @@  module Data.JsonSchema.Draft4.Schema where -import           Import-import           Prelude+import           Import                hiding (mapMaybe) -import qualified Data.HashMap.Strict          as HM-import           Data.List.NonEmpty           (NonEmpty)-import           Data.Maybe                   (fromJust, isJust)+import qualified Data.HashMap.Strict   as HM+import           Data.List.NonEmpty    (NonEmpty)+import           Data.Maybe            (fromJust, isJust) import           Data.Scientific+import qualified Data.Set              as Set+import qualified Data.Text             as T -import qualified Data.Validator.Draft4.Any    as AN-import qualified Data.Validator.Draft4.Array  as AR-import qualified Data.Validator.Draft4.Object as OB+import qualified Data.Validator.Draft4 as D4 import           Data.Validator.Utils  data Schema = Schema@@ -26,6 +25,10 @@     -- contain schemas anywhere (not just in "definitions" or any     -- of the other official keys) we save any leftover key/value     -- pairs not covered by them here.+    --+    -- TODO: This field is the source of most of the complication in this+    -- module and needs to be removed. It should be doable, though it will+    -- involve some modification to the fetching code.      , _schemaMultipleOf           :: Maybe Scientific     , _schemaMaximum              :: Maybe Scientific@@ -40,22 +43,22 @@     , _schemaMaxItems             :: Maybe Int     , _schemaMinItems             :: Maybe Int     , _schemaUniqueItems          :: Maybe Bool-    , _schemaItems                :: Maybe (AR.Items Schema)+    , _schemaItems                :: Maybe (D4.Items Schema)     -- Note that '_schemaAdditionalItems' is left out of 'runValidate'     -- because its functionality is handled by '_schemaItems'. It always     -- validates data unless 'Items' is present.-    , _schemaAdditionalItems      :: Maybe (AR.AdditionalItems Schema)+    , _schemaAdditionalItems      :: Maybe (D4.AdditionalItems Schema)      , _schemaMaxProperties        :: Maybe Int     , _schemaMinProperties        :: Maybe Int-    , _schemaRequired             :: Maybe OB.Required-    , _schemaDependencies         :: Maybe (HashMap Text (OB.Dependency Schema))+    , _schemaRequired             :: Maybe (Set Text)+    , _schemaDependencies         :: Maybe (HashMap Text (D4.Dependency Schema))     , _schemaProperties           :: Maybe (HashMap Text Schema)     , _schemaPatternProperties    :: Maybe (HashMap Text Schema)-    , _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema)+    , _schemaAdditionalProperties :: Maybe (D4.AdditionalProperties Schema) -    , _schemaEnum                 :: Maybe AN.EnumVal-    , _schemaType                 :: Maybe AN.TypeVal+    , _schemaEnum                 :: Maybe (NonEmpty Value)+    , _schemaType                 :: Maybe D4.TypeValidator     , _schemaAllOf                :: Maybe (NonEmpty Schema)     , _schemaAnyOf                :: Maybe (NonEmpty Schema)     , _schemaOneOf                :: Maybe (NonEmpty Schema)@@ -262,9 +265,9 @@             a  <- maybeGen arbitraryText             b  <- maybeGen arbitraryText             c  <- maybeGen arbitraryText-               -- NOTE: The next two fields are empty to generate cleaner schemas,-               -- but note that this means we don't test e.g. the invertability-               -- of these fields.+               -- NOTE: The next two fields are empty to generate cleaner+               -- schemas, but note that this means we don't test the+               -- invertability of these fields.             d  <- pure Nothing -- _schemaDefinitions             e  <- pure mempty -- _otherPairs @@ -286,13 +289,14 @@              s  <- maybeGen (getPositive <$> arbitrary)             t  <- maybeGen (getPositive <$> arbitrary)-            u  <- arbitrary+            u  <- maybeGen (Set.map T.pack <$> arbitrary)             v  <- maybeRecurse n arbitraryHashMap             w  <- maybeRecurse n arbitraryHashMap             x  <- maybeRecurse n arbitraryHashMap             y  <- maybeRecurse n arbitrary -            z  <- arbitrary+            z  <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty'+                               <$> arbitrary)             a2 <- arbitrary             b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)             c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)

@@ -2,10 +2,8 @@ module Data.JsonSchema.Draft4.Spec where  import           Import--- Hiding is for GHCs before 7.10:-import           Prelude                        hiding (concat) -import           Data.Maybe                     (fromMaybe, isNothing)+import           Data.Maybe                     (fromMaybe) import           Data.Profunctor                (Profunctor(..))  import           Data.JsonSchema.Draft4.Failure@@ -15,33 +13,26 @@ import qualified Data.JsonSchema.Fetch          as FE import           Data.JsonSchema.Types          (Spec(..)) import qualified Data.JsonSchema.Types          as JT-import qualified Data.Validator.Draft4          as D4-import qualified Data.Validator.Draft4.Any      as AN+import           Data.Validator.Draft4 import           Data.Validator.Reference       (updateResolutionScope)  embedded :: Schema -> ([Schema], [Schema]) embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s --- | For internal use.------ A specialized version of 'const' that prevents overwriting--- useful information.-toss :: a -> () -> a-toss = const--validate+specValidate     :: ReferencedSchemas Schema     -> SchemaWithURI Schema     -> Value-    -> [Failure]-validate rs = continueValidating rs (AN.VisitedSchemas [(Nothing, Nothing)])+    -> [ValidatorFailure]+specValidate rs =+    continueValidating rs (VisitedSchemas [(Nothing, Nothing)])  continueValidating     :: ReferencedSchemas Schema-    -> AN.VisitedSchemas+    -> VisitedSchemas     -> SchemaWithURI Schema     -> Value-    -> [Failure]+    -> [ValidatorFailure] continueValidating referenced visited sw =     JT.validate (d4Spec referenced visited currentScope)                 (_swSchema sw)@@ -53,85 +44,85 @@  d4Spec     :: ReferencedSchemas Schema-    -> AN.VisitedSchemas+    -> VisitedSchemas     -> Maybe Text-    -> Spec Schema ValidatorChain+    -> Spec Schema ValidatorFailure d4Spec referenced visited scope = Spec-    [ dimap-        (fmap D4.MultipleOf . _schemaMultipleOf)-        (toss MultipleOf)-        D4.multipleOf+    [ dimap (fmap MultipleOf . _schemaMultipleOf) FailureMultipleOf multipleOfValidator     , dimap-        (\s -> D4.MaximumContext (fromMaybe False (_schemaExclusiveMaximum s))-                 <$> _schemaMaximum s)-        maxE-        D4.maximumVal+        (\s -> Maximum (fromMaybe False (_schemaExclusiveMaximum s)) <$> _schemaMaximum s)+        FailureMaximum+        maximumValidator     , dimap-        (\s -> D4.MinimumContext (fromMaybe False (_schemaExclusiveMinimum s))-                 <$> _schemaMinimum s)-        minE-        D4.minimumVal+        (\s -> Minimum (fromMaybe False (_schemaExclusiveMinimum s)) <$> _schemaMinimum s)+        FailureMinimum+        minimumValidator -    , dimap (fmap D4.MaxLength . _schemaMaxLength) (toss MaxLength) D4.maxLength-    , dimap (fmap D4.MinLength . _schemaMinLength) (toss MinLength) D4.minLength-    , dimap (fmap D4.PatternVal . _schemaPattern) (toss PatternValidator) D4.patternVal+    , dimap (fmap MaxLength . _schemaMaxLength) FailureMaxLength maxLengthValidator+    , dimap (fmap MinLength . _schemaMinLength) FailureMinLength minLengthValidator+    , dimap (fmap PatternValidator . _schemaPattern) FailurePattern patternValidator -    , dimap (fmap D4.MaxItems . _schemaMaxItems) (toss MaxItems) D4.maxItems-    , dimap (fmap D4.MinItems . _schemaMinItems) (toss MinItems) D4.minItems-    , dimap (fmap D4.UniqueItems . _schemaUniqueItems) (toss UniqueItems) D4.uniqueItems+    , dimap (fmap MaxItems . _schemaMaxItems) FailureMaxItems maxItemsValidator+    , dimap (fmap MinItems . _schemaMinItems) FailureMinItems minItemsValidator+    , dimap (fmap UniqueItems . _schemaUniqueItems) FailureUniqueItems uniqueItemsValidator     , dimap-        (\s -> D4.ItemsContext (_schemaAdditionalItems s) <$> _schemaItems s)-        itemsE-        (D4.items descend)-    , lmap (fmap D4.AdditionalItemsContext . _schemaAdditionalItems) D4.additionalItemsEmbedded-    , lmap (fmap D4.Definitions . _schemaDefinitions) D4.definitionsEmbedded+        (\s -> ItemsRelated+                   { _irItems      = _schemaItems s+                   , _irAdditional = _schemaAdditionalItems s+                   })+        (\err -> case err of+                     IRInvalidItems e      -> FailureItems e+                     IRInvalidAdditional e -> FailureAdditionalItems e)+        (itemsRelatedValidator descend)+    , lmap (fmap Definitions . _schemaDefinitions) definitionsEmbedded -    , dimap (fmap D4.MaxProperties . _schemaMaxProperties) (toss MaxProperties) D4.maxProperties-    , dimap (fmap D4.MinProperties . _schemaMinProperties) (toss MinProperties) D4.minProperties-    , dimap (fmap D4.RequiredContext . _schemaRequired) (toss Required) D4.required-    , dimap (fmap D4.DependenciesContext . _schemaDependencies) depsE (D4.dependencies descend)     , dimap-        (\s -> D4.PropertiesContext-                 (_schemaPatternProperties s)-                 (_schemaAdditionalProperties s)-                 <$> _schemaProperties s)-        propE-        (D4.properties descend)+        (fmap MaxProperties . _schemaMaxProperties)+        FailureMaxProperties+        maxPropertiesValidator     , dimap-        (\s -> D4.PatternPropertiesContext-                 (isNothing (_schemaProperties s))-                 (_schemaAdditionalProperties s)-                 <$> _schemaPatternProperties s)-        patPropE-        (D4.patternProperties descend)+        (fmap MinProperties . _schemaMinProperties)+        FailureMinProperties+        minPropertiesValidator+    , dimap (fmap Required . _schemaRequired) FailureRequired requiredValidator     , dimap-        (\s -> D4.AdditionalPropertiesContext-                 (isNothing (_schemaProperties s)-                    && isNothing (_schemaPatternProperties s))-                 <$> _schemaAdditionalProperties s)-        addPropE-        (D4.additionalProperties descend)+        (fmap DependenciesValidator . _schemaDependencies)+        FailureDependencies+        (dependenciesValidator descend)+    , dimap+        (\s -> PropertiesRelated+                   { _propProperties = _schemaProperties s+                   , _propPattern    = _schemaPatternProperties s+                   , _propAdditional = _schemaAdditionalProperties s+                   })+        FailurePropertiesRelated+        (propertiesRelatedValidator descend)      , dimap-        (\s -> D4.Ref <$> _schemaRef s)-        refE-        (D4.ref visited scope (FE.getReference referenced) refVal)-    , dimap (fmap D4.EnumContext . _schemaEnum) (toss Enum) D4.enumVal-    , dimap (fmap D4.TypeContext . _schemaType) (toss TypeValidator) D4.typeVal-    , dimap (fmap D4.AllOf . _schemaAllOf) AllOf (D4.allOf lateral)-    , dimap (fmap D4.AnyOf . _schemaAnyOf) AnyOf (D4.anyOf lateral)-    , dimap (fmap D4.OneOf . _schemaOneOf) oneOfE (D4.oneOf lateral)-    , dimap (fmap D4.NotVal . _schemaNot) (toss NotValidator) (D4.notVal lateral)+        (\s -> Ref <$> _schemaRef s)+        FailureRef+        (refValidator visited scope (FE.getReference referenced) getRef)+    , dimap (fmap EnumValidator . _schemaEnum) FailureEnum enumValidator+    , dimap (fmap TypeContext . _schemaType) FailureType typeValidator+    , dimap (fmap AllOf . _schemaAllOf) FailureAllOf (allOfValidator lateral)+    , dimap (fmap AnyOf . _schemaAnyOf) FailureAnyOf (anyOfValidator lateral)+    , dimap (fmap OneOf . _schemaOneOf) FailureOneOf (oneOfValidator lateral)+    , dimap (fmap NotValidator . _schemaNot) FailureNot (notValidator lateral)     ]   where-    refVal :: AN.VisitedSchemas -> Maybe Text -> Schema -> Value -> [Failure]-    refVal newVisited newScope schema =+    getRef+        :: VisitedSchemas+        -> Maybe Text+        -> Schema+        -> Value+        -> [ValidatorFailure]+    getRef newVisited newScope schema =         continueValidating referenced newVisited (SchemaWithURI schema newScope) -    descend :: Schema -> Value -> [Failure]+    descend :: Schema -> Value -> [ValidatorFailure]     descend schema =         continueValidating referenced mempty (SchemaWithURI schema scope) -    lateral :: Schema -> Value -> [Failure]+    lateral :: Schema -> Value -> [ValidatorFailure]     lateral schema =         continueValidating referenced visited (SchemaWithURI schema scope)

@@ -2,15 +2,13 @@ module Data.JsonSchema.Fetch where  import           Import--- Hiding is for GHCs before 7.10:-import           Prelude                  hiding (concat, sequence)  import           Control.Arrow            (left)-import           Control.Exception        (catch)+import           Control.Exception        (IOException, catch) import           Control.Monad            (foldM)-import qualified Data.ByteString.Lazy     as LBS import qualified Data.ByteString          as BS-import qualified Data.HashMap.Strict      as H+import qualified Data.ByteString.Lazy     as LBS+import qualified Data.HashMap.Strict      as HM import qualified Data.Text                as T import qualified Network.HTTP.Client      as NC @@ -50,11 +48,14 @@       --     }       --   }       -- }-    , _rsSchemaMap :: !(URISchemaMap schema)+    , _rsSchemaMap :: !(HashMap Text schema)+      -- ^ Map of URIs to schemas.     } deriving (Eq, Show)  -- | Keys are URIs (without URI fragments).-type URISchemaMap schema = HashMap Text schema+newtype URISchemaMap schema+    = URISchemaMap { _unURISchemaMap :: HashMap Text schema }+    deriving (Eq, Show)  data SchemaWithURI schema = SchemaWithURI     { _swSchema :: !schema@@ -68,7 +69,7 @@  getReference :: ReferencedSchemas schema -> Maybe Text -> Maybe schema getReference referenced Nothing  = Just (_rsStarting referenced)-getReference referenced (Just t) = H.lookup t (_rsSchemaMap referenced)+getReference referenced (Just t) = HM.lookup t (_rsSchemaMap referenced)  -------------------------------------------------- -- * Fetch via HTTP@@ -88,13 +89,13 @@     -> IO (Either HTTPFailure (URISchemaMap schema)) referencesViaHTTP' info sw = do     manager <- NC.newManager NC.defaultManagerSettings-    let f = referencesMethodAgnostic (get manager) info sw+    let f = referencesMethodAgnostic (getURL manager) info sw     catch (left HTTPParseFailure <$> f) handler   where-    get :: NC.Manager -> Text -> IO LBS.ByteString-    get man url = do+    getURL :: NC.Manager -> Text -> IO BS.ByteString+    getURL man url = do         request <- NC.parseUrlThrow (T.unpack url)-        NC.responseBody <$> NC.httpLbs request man+        LBS.toStrict . NC.responseBody <$> NC.httpLbs request man      handler         :: NC.HttpException@@ -107,7 +108,7 @@  data FilesystemFailure     = FSParseFailure Text-    | FSReadFailure  IOError+    | FSReadFailure  IOException     deriving (Show, Eq)  referencesViaFilesystem'@@ -118,13 +119,10 @@ referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler   where     f :: IO (Either Text (URISchemaMap schema))-    f = referencesMethodAgnostic readFile' info sw--    readFile' :: Text -> IO LBS.ByteString-    readFile' = fmap LBS.fromStrict . BS.readFile . T.unpack+    f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw      handler-        :: IOError+        :: IOException         -> IO (Either FilesystemFailure (URISchemaMap schema))     handler = pure . Left . FSReadFailure @@ -137,16 +135,16 @@ -- e.g. rejecting non-local URIs. referencesMethodAgnostic     :: forall schema. FromJSON schema-    => (Text -> IO LBS.ByteString)+    => (Text -> IO BS.ByteString)     -> FetchInfo schema     -> SchemaWithURI schema     -> IO (Either Text (URISchemaMap schema)) referencesMethodAgnostic fetchRef info =-    getRecursiveReferences fetchRef info mempty+    getRecursiveReferences fetchRef info (URISchemaMap mempty)  getRecursiveReferences     :: forall schema. FromJSON schema-    => (Text -> IO LBS.ByteString)+    => (Text -> IO BS.ByteString)     -> FetchInfo schema     -> URISchemaMap schema     -> SchemaWithURI schema@@ -158,21 +156,23 @@       -> SchemaWithURI schema       -> IO (Either Text (URISchemaMap schema))     f (Left e) _                            = pure (Left e)-    f (Right g) (SchemaWithURI schema mUri) =+    f (Right (URISchemaMap usm)) (SchemaWithURI schema mUri) =         case newRef of-            Nothing  -> pure (Right g)+            Nothing  -> pure (Right (URISchemaMap usm))             Just uri -> do                 bts <- fetchRef uri-                case eitherDecode bts of+                case eitherDecodeStrict bts of                     Left e     -> pure . Left . T.pack $ e                     Right schm -> getRecursiveReferences-                                      fetchRef info (H.insert uri schm g)+                                      fetchRef+                                      info+                                      (URISchemaMap (HM.insert uri schm usm))                                       (SchemaWithURI schm (Just uri))       where         newRef :: Maybe Text         newRef           | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema-              = case H.lookup uri g of+              = case HM.lookup uri usm of                     Nothing -> Just uri                     Just _  -> Nothing           | otherwise = Nothing

@@ -1,12 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Data.JsonSchema.Types where -import           Prelude import           Import -import           Data.Validator.Failure (Fail)-import           Data.Validator.Types   (Validator(..))+import           Data.Validator.Types (Validator(..))  newtype Spec schema err     = Spec { _unSpec :: [Validator schema schema err] }@@ -25,8 +22,9 @@     :: Spec schema err     -> schema     -> Value-    -> [Fail err]-validate spec schema v = _unSpec spec >>= (\val -> _validate val schema v)+    -> [err]+validate spec schema v =+    (\val -> _validate val schema v) =<< _unSpec spec  -- | A basic schema type that doesn't impose much structure. --

@@ -1,38 +1,36 @@ -- | Turn the validation functions into actual 'Validator's.------ From this point on they know how to parse themselves from JSON--- and also know how to extract subschemas embedded within themselves. -module Data.Validator.Draft4 where+module Data.Validator.Draft4+    ( module Data.Validator.Draft4+    , module Export+    ) where -import           Prelude import           Import -import           Data.Aeson.Types             (Parser) import qualified Data.HashMap.Strict          as HM-import           Data.List.NonEmpty           (NonEmpty) import qualified Data.List.NonEmpty           as NE-import           Data.Maybe                   (catMaybes, isNothing,-                                               maybe, maybeToList)-import           Data.Scientific              (Scientific)+import           Data.Maybe                   (catMaybes, maybe, maybeToList) import           Data.Text                    (Text) -import qualified Data.Validator.Draft4.Any    as AN-import qualified Data.Validator.Draft4.Array  as AR-import qualified Data.Validator.Draft4.Number as NU-import qualified Data.Validator.Draft4.Object as OB-import qualified Data.Validator.Draft4.String as ST-import           Data.Validator.Failure       (Fail(..))+import           Data.Validator.Draft4.Any    as Export+import           Data.Validator.Draft4.Array  as Export+import           Data.Validator.Draft4.Number as Export+import           Data.Validator.Draft4.Object as Export+import           Data.Validator.Draft4.String as Export import           Data.Validator.Types         (Validator(..)) import           Data.Validator.Utils         (fromJSONEither)  -- | For internal use.-run :: FromJSON b => (a -> b -> [c]) -> Maybe a -> Value -> [c]+--+-- Take a validation function, a possibly existing validator, and some data.+-- If the validator is exists and can validate the type of data we have,+-- attempt to do so and return any failures.+run :: FromJSON b => (a -> b -> Maybe c) -> Maybe a -> Value -> [c] run _ Nothing _  = mempty run f (Just a) b =     case fromJSONEither b of         Left _  -> mempty-        Right c -> f a c+        Right c -> maybeToList (f a c)  -- | For internal use. noEmbedded :: a -> ([b], [b])@@ -42,190 +40,116 @@ -- * Numbers -------------------------------------------------- -newtype MultipleOf-    = MultipleOf { _unMultipleOf :: Scientific }-    deriving (Eq, Show)--instance FromJSON MultipleOf where-    parseJSON = withObject "MultipleOf" $ \o ->-        MultipleOf <$> o .: "multipleOf"--multipleOf :: Validator a (Maybe MultipleOf) ()-multipleOf =-    Validator-        noEmbedded-        (run (fmap maybeToList . NU.multipleOf . _unMultipleOf))--data MaximumContext-    = MaximumContext Bool Scientific-    deriving (Eq, Show)--instance FromJSON MaximumContext where-    parseJSON = withObject "MaximumContext" $ \o -> MaximumContext-        <$> o .:! "exclusiveMaximum" .!= False-        <*> o .: "maximum"--maximumVal :: Validator a (Maybe MaximumContext) NU.MaximumInvalid-maximumVal =-    Validator-        noEmbedded-        (run (\(MaximumContext a b) -> maybeToList . NU.maximumVal a b))--data MinimumContext-    = MinimumContext Bool Scientific-    deriving (Eq, Show)+multipleOfValidator :: Validator a (Maybe MultipleOf) MultipleOfInvalid+multipleOfValidator = Validator noEmbedded (run multipleOfVal) -instance FromJSON MinimumContext where-    parseJSON = withObject "MinimumContext" $ \o -> MinimumContext-        <$> o .:! "exclusiveMinimum" .!= False-        <*> o .: "minimum"+maximumValidator :: Validator a (Maybe Maximum) MaximumInvalid+maximumValidator = Validator noEmbedded (run maximumVal) -minimumVal :: Validator a (Maybe MinimumContext) NU.MinimumInvalid-minimumVal =-    Validator-        noEmbedded-        (run (\(MinimumContext a b) -> maybeToList . NU.minimumVal a b))+minimumValidator :: Validator a (Maybe Minimum) MinimumInvalid+minimumValidator = Validator noEmbedded (run minimumVal)  -------------------------------------------------- -- * Strings -------------------------------------------------- -newtype MaxLength-    = MaxLength { _unMaxLength :: Int }-    deriving (Eq, Show)--instance FromJSON MaxLength where-    parseJSON = withObject "MaxLength" $ \o ->-        MaxLength <$> o .: "maxLength"--maxLength :: Validator a (Maybe MaxLength) ()-maxLength =-    Validator-        noEmbedded-        (run (fmap maybeToList . ST.maxLength . _unMaxLength))--newtype MinLength-    = MinLength { _unMinLength :: Int }-    deriving (Eq, Show)--instance FromJSON MinLength where-    parseJSON = withObject "MinLength" $ \o ->-        MinLength <$> o .: "minLength"--minLength :: Validator a (Maybe MinLength) ()-minLength =-    Validator-        noEmbedded-        (run (fmap maybeToList . ST.minLength . _unMinLength))--newtype PatternVal-    = PatternVal { _unPatternVal :: Text }-    deriving (Eq, Show)+maxLengthValidator :: Validator a (Maybe MaxLength) MaxLengthInvalid+maxLengthValidator = Validator noEmbedded (run maxLengthVal) -instance FromJSON PatternVal where-    parseJSON = withObject "PatternVal" $ \o ->-        PatternVal <$> o .: "pattern"+minLengthValidator :: Validator a (Maybe MinLength) MinLengthInvalid+minLengthValidator = Validator noEmbedded (run minLengthVal) -patternVal :: Validator a (Maybe PatternVal) ()-patternVal =-    Validator-        noEmbedded-        (run (fmap maybeToList . ST.patternVal . _unPatternVal))+patternValidator :: Validator a (Maybe PatternValidator) PatternInvalid+patternValidator = Validator noEmbedded (run patternVal)  -------------------------------------------------- -- * Arrays -------------------------------------------------- -newtype MaxItems-    = MaxItems { _unMaxItems :: Int }-    deriving (Eq, Show)--instance FromJSON MaxItems where-    parseJSON = withObject "MaxItems" $ \o ->-        MaxItems <$> o .: "maxItems"--maxItems :: Validator a (Maybe MaxItems) ()-maxItems =-    Validator-        noEmbedded-        (run (fmap maybeToList . AR.maxItems . _unMaxItems))+maxItemsValidator :: Validator a (Maybe MaxItems) MaxItemsInvalid+maxItemsValidator = Validator noEmbedded (run maxItemsVal) -newtype MinItems-    = MinItems { _unMinItems :: Int }-    deriving (Eq, Show)+minItemsValidator :: Validator a (Maybe MinItems) MinItemsInvalid+minItemsValidator = Validator noEmbedded (run minItemsVal) -instance FromJSON MinItems where-    parseJSON = withObject "MinItems" $ \o ->-        MinItems <$> o .: "minItems"+uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid+uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal) -minItems :: Validator a (Maybe MinItems) ()-minItems =+itemsRelatedValidator+    :: (schema -> Value -> [err])+    -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err)+itemsRelatedValidator f =     Validator-        noEmbedded-        (run (fmap maybeToList . AR.minItems . _unMinItems))--newtype UniqueItems-    = UniqueItems { _unUniqueItems :: Bool }-    deriving (Eq, Show)+        (\a -> ( mempty+               ,  case _irItems a of+                      Just (ItemsObject b) -> pure b+                      Just (ItemsArray cs) -> cs+                      Nothing              -> mempty+               <> case _irAdditional a of+                      Just (AdditionalObject b) -> pure b+                      _                         -> mempty+               ))+        (\a b -> case fromJSONEither b of+                     Left _  -> mempty+                     Right c -> itemsRelatedVal f a c) -instance FromJSON UniqueItems where-    parseJSON = withObject "UniqueItems" $ \o ->-        UniqueItems <$> o .: "uniqueItems"+--------------------------------------------------+-- * Objects+-------------------------------------------------- -uniqueItems :: Validator a (Maybe UniqueItems) ()-uniqueItems =-    Validator-        noEmbedded-        (run (fmap maybeToList . AR.uniqueItems . _unUniqueItems))+maxPropertiesValidator+    :: Validator+           a+           (Maybe MaxProperties)+           MaxPropertiesInvalid+maxPropertiesValidator = Validator noEmbedded (run maxPropertiesVal) -data ItemsContext schema =-    ItemsContext-        (Maybe (AR.AdditionalItems schema))-        (AR.Items schema)-    deriving (Eq, Show)+minPropertiesValidator+    :: Validator+           a+           (Maybe MinProperties)+           MinPropertiesInvalid+minPropertiesValidator = Validator noEmbedded (run minPropertiesVal) -instance FromJSON schema => FromJSON (ItemsContext schema) where-    parseJSON = withObject "ItemsContext" $ \o -> ItemsContext-        <$> o .:! "additionalItems"-        <*> o .: "items"+requiredValidator :: Validator a (Maybe Required) ()+requiredValidator = Validator noEmbedded (run requiredVal) -items-    :: (schema -> Value -> [Fail err])-    -> Validator schema (Maybe (ItemsContext schema)) (AR.ItemsInvalid err)-items f =+dependenciesValidator+    :: (schema -> Value -> [err])+    -> Validator+           schema+           (Maybe (DependenciesValidator schema))+           (DependenciesInvalid err)+dependenciesValidator f =     Validator-        (\a -> case a of-                   Nothing -> mempty-                   Just (ItemsContext _ b) ->-                       case b of-                           AR.ItemsObject c -> (mempty, pure c)-                           AR.ItemsArray cs -> (mempty, cs))-        (run (\(ItemsContext a b) -> AR.items f a b))--newtype AdditionalItemsContext schema-    = AdditionalItemsContext-        { _unAdditionalItemsContext :: AR.AdditionalItems schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (AdditionalItemsContext schema) where-    parseJSON = withObject "AdditionalItemsContext" $ \o ->-        AdditionalItemsContext <$> o .: "additionalItems"+        (maybe mempty ( (\a -> (mempty, a))+                      . catMaybes . fmap checkDependency+                      . HM.elems . _unDependenciesValidator+                      ))+        (run (dependenciesVal f))+  where+    checkDependency :: Dependency schema -> Maybe schema+    checkDependency (PropertyDependency _) = Nothing+    checkDependency (SchemaDependency s)   = Just s --- | Since 'items' will always take care of validating 'additionalItems'--- as well, the actual validation side of 'additionalItemsEmbedded' is--- disabled.-additionalItemsEmbedded-    :: Validator+propertiesRelatedValidator+    :: (schema -> Value -> [err])+    -> Validator            schema-           (Maybe (AdditionalItemsContext schema))-           err-additionalItemsEmbedded=+           (PropertiesRelated schema)+           (PropertiesRelatedInvalid err)+propertiesRelatedValidator f =     Validator-        (\a -> case a of-                   Just (AdditionalItemsContext (AR.AdditionalObject b)) ->-                       (mempty, pure b)-                   _ -> (mempty, mempty))-        (const (const mempty))+        (\a -> ( mempty+               ,  HM.elems (fromMaybe mempty (_propProperties a))+               <> HM.elems (fromMaybe mempty (_propPattern a))+               <> case _propAdditional a of+                      Just (AdditionalPropertiesObject b) -> [b]+                      _ -> mempty+               ))+        (\a b -> case fromJSONEither b of+                     Left _  -> mempty+                     Right c -> maybeToList (propertiesRelatedVal f a c))  newtype Definitions schema     = Definitions { _unDefinitions :: HashMap Text schema }@@ -235,11 +159,9 @@     parseJSON = withObject "Definitions" $ \o ->         Definitions <$> o .: "definitions" --- | Placing this here since it's similar to @"additionalItems"@.--- in that its validator doesn't run.------ TODO: Add tests to the language agnostic test suite for both--- @"additionalItems"@ and this.+-- TODO: Add tests to the language agnostic test suite to+-- make sure these schemas are embedded correctly+-- (and do so for @"additionalItems"@ as well). definitionsEmbedded     :: Validator            schema@@ -253,298 +175,68 @@         (const (const mempty))  ----------------------------------------------------- * Objects-----------------------------------------------------newtype MaxProperties-    = MaxProperties { _unMaxProperties :: Int }-    deriving (Eq, Show)--instance FromJSON MaxProperties where-    parseJSON = withObject "MaxProperties" $ \o ->-        MaxProperties <$> o .: "maxProperties"--maxProperties :: Validator a (Maybe MaxProperties) ()-maxProperties =-    Validator-        noEmbedded-        (run (fmap maybeToList . OB.maxProperties . _unMaxProperties))--newtype MinProperties-    = MinProperties { _unMinProperties :: Int }-    deriving (Eq, Show)--instance FromJSON MinProperties where-    parseJSON = withObject "MinProperties" $ \o ->-        MinProperties <$> o .: "minProperties"--minProperties :: Validator a (Maybe MinProperties) ()-minProperties =-    Validator-        noEmbedded-        (run (fmap maybeToList . OB.minProperties . _unMinProperties))--newtype RequiredContext-    = RequiredContext { _unRequiredContext :: OB.Required }-    deriving (Eq, Show)--instance FromJSON RequiredContext where-    parseJSON = withObject "RequiredContext" $ \o ->-        RequiredContext <$> o .: "required"--required :: Validator a (Maybe RequiredContext) ()-required =-    Validator-        noEmbedded-        (run (fmap maybeToList . OB.required . _unRequiredContext))--newtype DependenciesContext schema-    = DependenciesContext-           { _unDependenciesContext :: HashMap Text (OB.Dependency schema) }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (DependenciesContext schema) where-    parseJSON = withObject "DependenciesContext" $ \o ->-        DependenciesContext <$> o .: "dependencies"--dependencies-    :: (schema -> Value -> [Fail err])-    -> Validator-           schema-           (Maybe (DependenciesContext schema))-           (OB.DependencyInvalid err)-dependencies f =-    Validator-        (maybe mempty ( (\a -> (mempty, a))-                      . catMaybes . fmap checkDependency-                      . HM.elems . _unDependenciesContext-                      ))-        (run (OB.dependencies f . _unDependenciesContext))-  where-    checkDependency :: OB.Dependency schema -> Maybe schema-    checkDependency (OB.PropertyDependency _) = Nothing-    checkDependency (OB.SchemaDependency s)   = Just s--data PropertiesContext schema-    = PropertiesContext-          (Maybe (HashMap Text schema))-          (Maybe (OB.AdditionalProperties schema))-          (HashMap Text schema)-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (PropertiesContext schema) where-    parseJSON = withObject "PropertiesContext" $ \o -> PropertiesContext-        <$> o .:! "patternProperties"-        <*> o .:! "additionalProperties"-        <*> o .: "properties"--properties-    :: (schema -> Value -> [Fail err])-    -> Validator-           schema-           (Maybe (PropertiesContext schema))-           (OB.PropertiesInvalid err)-properties f =-    Validator-        (\a -> case a of-                   Just (PropertiesContext _ _ b) -> (mempty, HM.elems b)-                   Nothing                        -> (mempty, mempty))-        (run (\(PropertiesContext a b c) -> OB.properties f a b c))---- | The first argument is whether the validator should be run.--- If @"properties"@ exists it will be parsed to 'False'.-data PatternPropertiesContext schema-    = PatternPropertiesContext-          Bool-          (Maybe (OB.AdditionalProperties schema))-          (HashMap Text schema)-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (PatternPropertiesContext schema) where-    parseJSON = withObject "PatternPropertiesContext" $ \o ->-        PatternPropertiesContext-            <$> shouldRun o-            <*> o .:! "additionalProperties"-            <*> o .: "patternProperties"-      where-        shouldRun :: HashMap Text Value -> Parser Bool-        shouldRun o = do-            a <- o .:! "properties"-            pure $ isNothing (a :: Maybe (HashMap Text schema))--patternProperties-    :: (schema -> Value -> [Fail err])-    -> Validator-           schema-           (Maybe (PatternPropertiesContext schema))-           (OB.PatternPropertiesInvalid err)-patternProperties f =-    Validator-        (\a -> case a of-                   Just (PatternPropertiesContext _ _ b) -> (mempty, HM.elems b)-                   Nothing                               -> (mempty, mempty))-        (run (\(PatternPropertiesContext a b c) -> OB.patternProperties f a b c))---- | The first argument is whether the validator should be run.--- If @"properties"@ or @"patternProperties"@ exist it will be parsed--- to 'False'.-data AdditionalPropertiesContext schema-    = AdditionalPropertiesContext-          Bool-          (OB.AdditionalProperties schema)-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (AdditionalPropertiesContext schema) where-    parseJSON = withObject "AdditionalPropertiesContext" $ \o ->-        AdditionalPropertiesContext-            <$> shouldRun o-            <*> o .: "additionalProperties"-      where-        shouldRun :: HashMap Text Value -> Parser Bool-        shouldRun o = do-            a <- o .:! "properties"-            b <- o .:! "patternProperties"-            pure $ isNothing (a :: Maybe (HashMap Text schema))-                && isNothing (b :: Maybe (HashMap Text schema))--additionalProperties-    :: (schema -> Value -> [Fail err])-    -> Validator-           schema-           (Maybe (AdditionalPropertiesContext schema))-           (OB.AdditionalPropertiesInvalid err)-additionalProperties f =-    Validator-        (\a -> case a of-                   Nothing -> mempty-                   Just (AdditionalPropertiesContext _ b) ->-                       case b of-                           OB.AdditionalPropertiesBool _   -> (mempty, mempty)-                           OB.AdditionalPropertiesObject c -> (mempty, pure c))-        (run (\(AdditionalPropertiesContext a b) -> OB.additionalProperties f a b))---------------------------------------------------- -- * Any -------------------------------------------------- -newtype Ref-    = Ref { _unRef :: Text }-    deriving (Eq, Show)--instance FromJSON Ref where-    parseJSON = withObject "Ref" $ \o ->-        Ref <$> o .: "$ref"--ref+refValidator     :: (FromJSON schema, ToJSON schema)-    => AN.VisitedSchemas+    => VisitedSchemas     -> Maybe Text     -> (Maybe Text -> Maybe schema)-    -> (AN.VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err])-    -> Validator a (Maybe Ref) (AN.RefInvalid err)-ref visited scope getRef f =-    Validator-        noEmbedded-        (run (AN.ref visited scope getRef f . _unRef))--newtype EnumContext-    = EnumContext { _unEnumContext :: AN.EnumVal }-    deriving (Eq, Show)--instance FromJSON EnumContext where-    parseJSON = withObject "EnumContext" $ \o ->-        EnumContext <$> o .: "enum"--enumVal :: Validator a (Maybe EnumContext) ()-enumVal =-    Validator-        noEmbedded-        (run (fmap maybeToList . AN.enumVal . _unEnumContext))--newtype TypeContext-    = TypeContext { _unTypeContext :: AN.TypeVal }-    deriving (Eq, Show)--instance FromJSON TypeContext where-    parseJSON = withObject "TypeContext" $ \o ->-        TypeContext <$> o .: "type"--typeVal :: Validator a (Maybe TypeContext) ()-typeVal =+    -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])+    -> Validator a (Maybe Ref) (RefInvalid err)+refValidator visited scope getRef f =     Validator         noEmbedded-        (run (fmap maybeToList . AN.typeVal . _unTypeContext))+        (run (refVal visited scope getRef f)) -newtype AllOf schema-    = AllOf { _unAllOf :: NonEmpty schema }-    deriving (Eq, Show)+enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid+enumValidator = Validator noEmbedded (run enumVal) -instance FromJSON schema => FromJSON (AllOf schema) where-    parseJSON = withObject "AllOf" $ \o ->-        AllOf <$> o .: "allOf"+typeValidator :: Validator a (Maybe TypeContext) TypeValidatorInvalid+typeValidator = Validator noEmbedded (run typeVal) -allOf-    :: (schema -> Value -> [Fail err])-    -> Validator schema (Maybe (AllOf schema)) err-allOf f =+allOfValidator+    :: (schema -> Value -> [err])+    -> Validator schema (Maybe (AllOf schema)) (AllOfInvalid err)+allOfValidator f =     Validator         (\a -> case a of                    Just (AllOf b) -> (NE.toList b, mempty)                    Nothing        -> (mempty, mempty))-        (run (AN.allOf f . _unAllOf))--newtype AnyOf schema-    = AnyOf { _unAnyOf :: NonEmpty schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (AnyOf schema) where-    parseJSON = withObject "AnyOf" $ \o ->-        AnyOf <$> o .: "anyOf"+        (run (allOfVal f)) -anyOf-    :: (schema -> Value -> [Fail err])-    -> Validator schema (Maybe (AnyOf schema)) err-anyOf f =+anyOfValidator+    :: (schema -> Value -> [err])+    -> Validator schema (Maybe (AnyOf schema)) (AnyOfInvalid err)+anyOfValidator f =     Validator         (\a -> case a of                  Just (AnyOf b) -> (NE.toList b, mempty)                  Nothing        -> (mempty, mempty))-        (run (AN.anyOf f . _unAnyOf))--newtype OneOf schema-    = OneOf { _unOneOf :: NonEmpty schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (OneOf schema) where-    parseJSON = withObject "OneOf" $ \o ->-        OneOf <$> o .: "oneOf"+        (run (anyOfVal f)) -oneOf+oneOfValidator     :: ToJSON schema-    => (schema -> Value -> [Fail err])-    -> Validator schema (Maybe (OneOf schema)) (AN.OneOfInvalid err)-oneOf f =+    => (schema -> Value -> [err])+    -> Validator schema (Maybe (OneOf schema)) (OneOfInvalid err)+oneOfValidator f =     Validator         (\a -> case a of                    Just (OneOf b) -> (NE.toList b, mempty)                    Nothing        -> (mempty, mempty))-        (run (AN.oneOf f . _unOneOf))--newtype NotVal schema-    = NotVal { _unNotVal :: schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (NotVal schema) where-    parseJSON = withObject "NotVal" $ \o ->-        NotVal <$> o .: "not"+        (run (oneOfVal f)) -notVal+notValidator     :: ToJSON schema-    => (schema -> Value -> [Fail err])-    -> Validator schema (Maybe (NotVal schema)) ()-notVal f =+    => (schema -> Value -> [err])+    -> Validator+           schema+           (Maybe (NotValidator schema))+           NotValidatorInvalid+notValidator f =     Validator         (\a -> case a of-                   Just (NotVal b) -> (pure b, mempty)-                   Nothing         -> (mempty, mempty))-        (run (fmap maybeToList . AN.notVal f . _unNotVal))+                   Just (NotValidator b) -> (pure b, mempty)+                   Nothing               -> (mempty, mempty))+        (run (notVal f))

@@ -1,22 +1,16 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Data.Validator.Draft4.Any where  import           Import--- Hiding is for GHCs before 7.10:-import           Prelude hiding           (any, concat, elem) -import           Control.Monad-import           Data.Aeson.Types         (Parser)-import           Data.List                (partition)-import           Data.List.NonEmpty       (NonEmpty)+import           Data.List.NonEmpty       (NonEmpty((:|))) import qualified Data.List.NonEmpty       as NE-import           Data.Maybe import qualified Data.Scientific          as SCI+import           Data.Semigroup           (Semigroup) -- for older GHCs import           Data.Set                 (Set) import qualified Data.Set                 as S+import qualified JSONPointer              as JP -import           Data.Validator.Failure   (Fail(..)) import qualified Data.Validator.Utils     as UT import           Data.Validator.Reference (URIBaseAndFragment,                                            resolveFragment, resolveReference)@@ -25,43 +19,61 @@ -- * $ref -------------------------------------------------- +newtype Ref+    = Ref { _unRef :: Text }+    deriving (Eq, Show)++instance FromJSON Ref where+    parseJSON = withObject "Ref" $ \o ->+        Ref <$> o .: "$ref"+ data RefInvalid err-    = RefResolution-    | RefLoop-    | RefInvalid err+    = RefResolution        Text+      -- ^ Indicates a reference that failed to resolve.+      --+      -- NOTE: The language agnostic test suite doesn't specify if this should+      -- cause a validation error or should allow data to pass. We choose to+      -- return a validation error.+      --+      -- Also note that ideally we would enforce in the type system that any+      -- failing references be dealt with before valididation. Then this could+      -- be removed entirely.+    | RefPointerResolution Text+    | RefLoop              Text VisitedSchemas URIBaseAndFragment+    | RefInvalid           Text Value (NonEmpty err)+      -- ^ 'Text' is the URI and 'Value' is the linked schema.     deriving (Eq, Show)  newtype VisitedSchemas     = VisitedSchemas { _unVisited :: [URIBaseAndFragment] }-    deriving (Eq, Show, Monoid)+    deriving (Eq, Show, Semigroup, Monoid) -ref+refVal     :: forall err schema. (FromJSON schema, ToJSON schema)     => VisitedSchemas     -> Maybe Text     -> (Maybe Text -> Maybe schema)-    -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err])-    -> Text+    -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])+    -> Ref     -> Value-    -> [Fail (RefInvalid err)]-ref visited scope getRef f reference x-    | (mUri, mFragment) `elem` _unVisited visited =-        pure $ Failure RefLoop (toJSON reference) mempty x+    -> Maybe (RefInvalid err)+refVal visited scope getRef f (Ref reference) x+    | (mURI, mFragment) `elem` _unVisited visited =+        Just (RefLoop reference visited (mURI, mFragment))     | otherwise =-        case getRef mUri of-            Nothing     -> pure failureDNE+        case getRef mURI of+            Nothing     -> Just (RefResolution reference)             Just schema ->                 case resolveFragment mFragment schema of-                    Nothing -> pure failureDNE+                    Nothing -> Just (RefPointerResolution reference)                     Just s  ->-                        let newVisited = (VisitedSchemas [(mUri, mFragment)]+                        let newVisited = (VisitedSchemas [(mURI, mFragment)]                                       <> visited)-                        in fmap RefInvalid <$> f newVisited mUri s x+                            errs = f newVisited mURI s x+                        in RefInvalid reference (toJSON schema)+                            <$> NE.nonEmpty errs   where-    (mUri, mFragment) = resolveReference scope reference--    failureDNE :: Fail (RefInvalid err)-    failureDNE = Failure RefResolution (toJSON reference) mempty x+    (mURI, mFragment) = resolveReference scope reference  -------------------------------------------------- -- * enum@@ -76,77 +88,84 @@ -- -- NOTE: We don't enforce the uniqueness constraint in the haskell code, -- but we do in the 'FromJSON' instance.-newtype EnumVal-    = EnumVal { _unEnumVal :: NonEmpty Value }+newtype EnumValidator+    = EnumValidator { _unEnumValidator :: NonEmpty Value }     -- Given a choice, we'd prefer to enforce uniqueness through the type     -- system over having at least one element. To use a 'Set' though we'd     -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)     -- and we'd rather not make users mess with 'OrdValue'.     deriving (Eq, Show) -instance FromJSON EnumVal where-    parseJSON v = checkUnique . UT._unNonEmpty' =<< parseJSON v-      where-        checkUnique :: NonEmpty Value -> Parser EnumVal-        checkUnique a-            | UT.allUniqueValues' a = pure (EnumVal a)-            | otherwise = fail "All elements of the Enum validator must be unique."--instance ToJSON EnumVal where-    toJSON = toJSON . UT.NonEmpty' . _unEnumVal+instance FromJSON EnumValidator where+    parseJSON = withObject "EnumValidator" $ \o ->+        EnumValidator <$> o .: "enum" -instance Arbitrary EnumVal where+instance Arbitrary EnumValidator where     arbitrary = do         xs <- (fmap.fmap) UT._unArbitraryValue arbitrary         case NE.nonEmpty (toUnique xs) of-            Nothing -> EnumVal . pure . UT._unArbitraryValue <$> arbitrary-            Just ne -> pure (EnumVal ne)+            Nothing -> EnumValidator . pure . UT._unArbitraryValue <$> arbitrary+            Just ne -> pure (EnumValidator ne)       where         toUnique :: [Value] -> [Value]         toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue -enumVal :: EnumVal -> Value -> Maybe (Fail ())-enumVal (EnumVal vs) x+data EnumInvalid+    = EnumInvalid EnumValidator Value+    deriving (Eq, Show)++enumVal :: EnumValidator -> Value -> Maybe EnumInvalid+enumVal a@(EnumValidator vs) x     | not (UT.allUniqueValues' vs) = Nothing     | x `elem` vs                  = Nothing-    | otherwise                    = Just $ Failure () (toJSON (UT.NonEmpty' vs))-                                                    mempty x+    | otherwise                    = Just $ EnumInvalid a x  -------------------------------------------------- -- * type -------------------------------------------------- -data TypeVal-    = TypeValString Text-    | TypeValArray (Set Text)+-- | This is separate from 'TypeValidator' so that 'TypeValidator' can+-- be used to write 'Data.JsonSchema.Draft4.Schema.Schema' without+-- messing up the 'FromJSON' instance of that data type.+newtype TypeContext+    = TypeContext { _unTypeContext :: TypeValidator }     deriving (Eq, Show) -instance FromJSON TypeVal where-    parseJSON v = fmap TypeValString (parseJSON v)-              <|> fmap TypeValArray (parseJSON v)+instance FromJSON TypeContext where+    parseJSON = withObject "TypeContext" $ \o ->+        TypeContext <$> o .: "type" -instance ToJSON TypeVal where-    toJSON (TypeValString t) = toJSON t-    toJSON (TypeValArray ts) = toJSON ts+data TypeValidator+    = TypeValidatorString Text+    | TypeValidatorArray  (Set Text)+    deriving (Eq, Show) -instance Arbitrary TypeVal where-    arbitrary = oneof [ TypeValString <$> UT.arbitraryText-                      , TypeValArray <$> UT.arbitrarySetOfText+instance FromJSON TypeValidator where+    parseJSON v = fmap TypeValidatorString (parseJSON v)+              <|> fmap TypeValidatorArray (parseJSON v)++instance ToJSON TypeValidator where+    toJSON (TypeValidatorString t) = toJSON t+    toJSON (TypeValidatorArray ts) = toJSON ts++instance Arbitrary TypeValidator where+    arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText+                      , TypeValidatorArray <$> UT.arbitrarySetOfText                       ] -setFromTypeVal :: TypeVal -> Set Text-setFromTypeVal (TypeValString t) = S.singleton t-setFromTypeVal (TypeValArray ts) = ts+data TypeValidatorInvalid+    = TypeValidatorInvalid TypeValidator Value+    deriving (Eq, Show) -typeVal :: TypeVal -> Value -> Maybe (Fail ())-typeVal tv x-    | S.null matches = Just (Failure () (toJSON tv) mempty x)+typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid+typeVal (TypeContext tv) x+    | S.null matches = Just (TypeValidatorInvalid tv x)     | otherwise      = Nothing   where     -- There can be more than one match because a 'Value' can be both a     -- @"number"@ and an @"integer"@.     matches :: Set Text-    matches = S.intersection okTypes (setFromTypeVal tv)+    matches = S.intersection okTypes (setFromTypeValidator tv)      okTypes :: Set Text     okTypes =@@ -161,76 +180,171 @@                     then S.fromList ["number", "integer"]                     else S.singleton "number" +-- | Internal.+setFromTypeValidator :: TypeValidator -> Set Text+setFromTypeValidator (TypeValidatorString t) = S.singleton t+setFromTypeValidator (TypeValidatorArray ts) = ts+ -------------------------------------------------- -- * allOf -------------------------------------------------- -allOf-    :: (schema -> Value -> [Fail err])-    -> NonEmpty schema+newtype AllOf schema+    = AllOf { _unAllOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AllOf schema) where+    parseJSON = withObject "AllOf" $ \o ->+        AllOf <$> o .: "allOf"++newtype AllOfInvalid err+    = AllOfInvalid (NonEmpty (JP.Index, NonEmpty err))+    deriving (Eq, Show)++allOfVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> AllOf schema     -> Value-    -> [Fail err]-allOf f subSchemas x = NE.toList subSchemas >>= flip f x+    -> Maybe (AllOfInvalid err)+allOfVal f (AllOf subSchemas) x = AllOfInvalid <$> NE.nonEmpty failures+  where+    perhapsFailures :: [(JP.Index, [err])]+    perhapsFailures = zip (JP.Index <$> [0..])+                          (flip f x <$> NE.toList subSchemas) +    failures :: [(JP.Index, NonEmpty err)]+    failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures+ -------------------------------------------------- -- * anyOf -------------------------------------------------- -anyOf+newtype AnyOf schema+    = AnyOf { _unAnyOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AnyOf schema) where+    parseJSON = withObject "AnyOf" $ \o ->+        AnyOf <$> o .: "anyOf"++newtype AnyOfInvalid err+    = AnyOfInvalid (NonEmpty (JP.Index, NonEmpty err))+    deriving (Eq, Show)++anyOfVal     :: forall err schema.-       (schema -> Value -> [Fail err])-    -> NonEmpty schema+       (schema -> Value -> [err])+    -> AnyOf schema     -> Value-    -> [Fail err]-anyOf f subSchemas x-    | any null results = mempty-    | otherwise        = concat results+    -> Maybe (AnyOfInvalid err)+anyOfVal f (AnyOf subSchemas) x+    -- Replace with @null@ once we drop GHC 7.8:+    | any (((==) 0 . length) . snd) perhapsFailures = Nothing+    | otherwise = AnyOfInvalid <$> NE.nonEmpty failures   where-    results :: [[Fail err]]-    results = flip f x <$> NE.toList subSchemas+    perhapsFailures :: [(JP.Index, [err])]+    perhapsFailures = zip (JP.Index <$> [0..])+                          (flip f x <$> NE.toList subSchemas) +    failures :: [(JP.Index, NonEmpty err)]+    failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures+ -------------------------------------------------- -- * oneOf -------------------------------------------------- +newtype OneOf schema+    = OneOf { _unOneOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (OneOf schema) where+    parseJSON = withObject "OneOf" $ \o ->+        OneOf <$> o .: "oneOf"+ data OneOfInvalid err-    = TooManySuccesses-    | NoSuccesses err+    = TooManySuccesses (NonEmpty (JP.Index, Value)) Value+      -- ^ The NonEmpty lists contains tuples whose contents+      -- are the index of a schema that validated the data+      -- and the contents of that schema.+    | NoSuccesses      (NonEmpty (JP.Index, NonEmpty err)) Value+      -- ^ The NonEmpty lists contains tuples whose contents+      -- are the index of a schema that failed to validate the data+      -- and the failures it produced.     deriving (Eq, Show) -oneOf+oneOfVal     :: forall err schema. ToJSON schema-    => (schema -> Value -> [Fail err])-    -> NonEmpty schema+    => (schema -> Value -> [err])+    -> OneOf schema     -> Value-    -> [Fail (OneOfInvalid err)]-oneOf f subSchemas x-    | length successes == 1 = mempty-    | length successes > 1  = pure tooManySuccesses-    | otherwise             = fmap NoSuccesses <$> concat failures+    -> Maybe (OneOfInvalid err)+oneOfVal f (OneOf (firstSubSchema :| otherSubSchemas)) x =+    -- Producing the NonEmpty lists needed by the error constructors+    -- is a little tricky. If we had a partition function like this+    -- it might help:+    -- @+    -- (a -> Either b c) -> NonEmpty a -> Either (NonEmpty b, [c])+    --                                           ([b], NonEmpty c)+    -- @+    case (firstSuccess, otherSuccesses) of+        (Right _, Nothing)        -> Nothing+        (Right a, Just successes) -> Just (TooManySuccesses+                                              (a NE.<| successes) x)+        (Left e, Nothing)        -> Just (NoSuccesses (e :| otherFailures) x)+        (Left _, Just (_ :| [])) -> Nothing+        (Left _, Just successes) -> Just (TooManySuccesses successes x)   where-    (successes, failures) = partition null results+    firstSuccess :: Either (JP.Index, NonEmpty err) (JP.Index, Value)+    firstSuccess =+        case NE.nonEmpty (f firstSubSchema x) of+            Nothing   -> Right (JP.Index 0, toJSON firstSubSchema)+            Just errs -> Left (JP.Index 0, errs) -    results :: [[Fail err]]-    results = flip f x <$> NE.toList subSchemas+    otherPerhapsFailures :: [(JP.Index, Value, [err])]+    otherPerhapsFailures =+        zipWith+            (\index schema -> (index, toJSON schema, f schema x))+            (JP.Index <$> [0..])+            otherSubSchemas -    -- NOTE: This could also return information about the specific-    -- validators that succeeded.-    tooManySuccesses :: Fail (OneOfInvalid err)-    tooManySuccesses = Failure TooManySuccesses-                               (toJSON (UT.NonEmpty' subSchemas)) mempty x+    otherSuccesses :: Maybe (NonEmpty (JP.Index, Value))+    otherSuccesses = NE.nonEmpty+                   $ mapMaybe (\(index,val,errs) ->+                                  case errs of+                                      [] -> Just (index,val)+                                      _  -> Nothing+                              ) otherPerhapsFailures +    otherFailures :: [(JP.Index, NonEmpty err)]+    otherFailures = mapMaybe (traverse NE.nonEmpty . mid) otherPerhapsFailures++    mid :: (a,b,c) -> (a,c)+    mid (a,_,c) = (a,c)+ -------------------------------------------------- -- * not -------------------------------------------------- +newtype NotValidator schema+    = NotValidator { _unNotValidator :: schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (NotValidator schema) where+    parseJSON = withObject "NotValidator" $ \o ->+        NotValidator <$> o .: "not"++data NotValidatorInvalid+    = NotValidatorInvalid Value Value+    deriving (Eq, Show)+ notVal-    :: ToJSON schema-    => (schema -> Value -> [Fail err])-    -> schema+    :: ToJSON schema =>+       (schema -> Value -> [err])+    -> NotValidator schema     -> Value-    -> Maybe (Fail ())-notVal f schema x =+    -> Maybe NotValidatorInvalid+notVal f (NotValidator schema) x =     case f schema x of-        [] -> Just (Failure () (toJSON schema) mempty x)+        [] -> Just (NotValidatorInvalid (toJSON schema) x)         _  -> Nothing

@@ -2,53 +2,101 @@ module Data.Validator.Draft4.Array where  import           Import-import           Prelude -import           Control.Monad-import qualified Data.Aeson.Pointer     as AP-import qualified Data.Text              as T-import qualified Data.Vector            as V-import           Text.Read              (readMaybe)+import qualified Data.List.NonEmpty   as NE+import qualified Data.Vector          as V+import qualified JSONPointer          as JP -import           Data.Validator.Failure (Fail(..), prependToPath)-import           Data.Validator.Utils   (allUniqueValues)+import           Data.Validator.Utils (allUniqueValues)  -------------------------------------------------- -- * maxItems -------------------------------------------------- +newtype MaxItems+    = MaxItems { _unMaxItems :: Int }+    deriving (Eq, Show)++instance FromJSON MaxItems where+    parseJSON = withObject "MaxItems" $ \o ->+        MaxItems <$> o .: "maxItems"++data MaxItemsInvalid+    = MaxItemsInvalid MaxItems (Vector Value)+    deriving (Eq, Show)+ -- | The spec requires @"maxItems"@ to be non-negative.-maxItems :: Int -> Vector Value -> Maybe (Fail ())-maxItems n xs+maxItemsVal :: MaxItems -> Vector Value -> Maybe MaxItemsInvalid+maxItemsVal a@(MaxItems n) xs     | n < 0           = Nothing-    | V.length xs > n = Just (Failure () (toJSON n) mempty (Array xs))+    | V.length xs > n = Just (MaxItemsInvalid a xs)     | otherwise       = Nothing  -------------------------------------------------- -- * minItems -------------------------------------------------- +newtype MinItems+    = MinItems { _unMinItems :: Int }+    deriving (Eq, Show)++instance FromJSON MinItems where+    parseJSON = withObject "MinItems" $ \o ->+        MinItems <$> o .: "minItems"++data MinItemsInvalid+    = MinItemsInvalid MinItems (Vector Value)+    deriving (Eq, Show)+ -- | The spec requires @"minItems"@ to be non-negative.-minItems :: Int -> Vector Value -> Maybe (Fail ())-minItems n xs+minItemsVal :: MinItems -> Vector Value -> Maybe MinItemsInvalid+minItemsVal a@(MinItems n) xs     | n < 0           = Nothing-    | V.length xs < n = Just (Failure () (toJSON n) mempty (Array xs))+    | V.length xs < n = Just (MinItemsInvalid a xs)     | otherwise       = Nothing  -------------------------------------------------- -- * uniqueItems -------------------------------------------------- -uniqueItems :: Bool -> Vector Value -> Maybe (Fail ())-uniqueItems True xs+newtype UniqueItems+    = UniqueItems { _unUniqueItems :: Bool }+    deriving (Eq, Show)++instance FromJSON UniqueItems where+    parseJSON = withObject "UniqueItems" $ \o ->+        UniqueItems <$> o .: "uniqueItems"++data UniqueItemsInvalid+    = UniqueItemsInvalid (Vector Value)+    deriving (Eq, Show)++uniqueItemsVal :: UniqueItems -> Vector Value -> Maybe UniqueItemsInvalid+uniqueItemsVal (UniqueItems True) xs    | allUniqueValues xs = Nothing-   | otherwise          = Just (Failure () (Bool True) mempty (Array xs))-uniqueItems False _ = Nothing+   | otherwise          = Just (UniqueItemsInvalid xs)+uniqueItemsVal (UniqueItems False) _ = Nothing  -------------------------------------------------- -- * items -------------------------------------------------- +data ItemsRelated schema = ItemsRelated+    { _irItems      :: Maybe (Items schema)+    , _irAdditional :: Maybe (AdditionalItems schema)+    } deriving (Eq, Show)++instance FromJSON schema => FromJSON (ItemsRelated schema) where+    parseJSON = withObject "ItemsRelated" $ \o -> ItemsRelated+        <$> o .:! "items"+        <*> o .:! "additionalItems"++emptyItems :: ItemsRelated schema+emptyItems = ItemsRelated+    { _irItems      = Nothing+    , _irAdditional = Nothing+    }+ data Items schema     = ItemsObject schema     | ItemsArray [schema]@@ -67,82 +115,73 @@                       , ItemsArray <$> arbitrary                       ] +data ItemsRelatedInvalid err+    = IRInvalidItems      (ItemsInvalid err)+    | IRInvalidAdditional (AdditionalItemsInvalid err)+    deriving (Eq, Show)+ data ItemsInvalid err-    = Items err-    | AdditionalItemsBoolInvalid-    | AdditionalItemsObjectInvalid err+    = ItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err))+    | ItemsArrayInvalid  (NonEmpty (JP.Index, NonEmpty err))     deriving (Eq, Show) -items+-- | @"additionalItems"@ only matters if @"items"@ exists+-- and is a JSON Array.+itemsRelatedVal     :: forall err schema.-       (schema -> Value -> [Fail err])-    -> Maybe (AdditionalItems schema)-    -> Items schema+       (schema -> Value -> [err])+    -> ItemsRelated schema     -> Vector Value-    -> [Fail (ItemsInvalid err)]-items f _ (ItemsObject subSchema) xs =-    zip [0..] (V.toList xs) >>= g-  where-    g :: (Int, Value) -> [Fail (ItemsInvalid err)]-    g (index,x) = fmap Items-                . prependToPath (AP.Token (T.pack (show index)))-              <$> f subSchema x+    -> [ItemsRelatedInvalid err] -- NOTE: 'Data.These' would help here.+itemsRelatedVal f a xs =+    let (itemsFailure, remaining) = case _irItems a of+                                        Nothing -> (Nothing, mempty)+                                        Just b  -> itemsVal f b xs+        additionalFailure = (\b -> additionalItemsVal f b remaining)+                        =<< _irAdditional a+    in catMaybes [ IRInvalidItems <$> itemsFailure+                 , IRInvalidAdditional <$> additionalFailure+                 ] -items f mAdditional (ItemsArray subSchemas) xs =-    itemFailures <> additionalItemFailures+-- | Internal.+--+-- This is because 'itemsRelated' handles @"items"@ validation.+itemsVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> Items schema+    -> Vector Value+    -> (Maybe (ItemsInvalid err), [(JP.Index, Value)])+       -- ^ The second item in the tuple is the elements of the original+       -- JSON Array still remaining to be checked by @"additionalItems"@.+itemsVal f a xs =+    case a of+        ItemsObject subSchema ->+            case NE.nonEmpty (mapMaybe (validateElem subSchema) indexed) of+                Nothing   -> (Nothing, mempty)+                Just errs -> (Just (ItemsObjectInvalid errs), mempty)+        ItemsArray subSchemas ->+            let remaining = drop (length subSchemas) indexed+                res = catMaybes (zipWith validateElem subSchemas indexed)+            in case NE.nonEmpty res of+                Nothing   -> (Nothing, remaining)+                Just errs -> (Just (ItemsArrayInvalid errs), remaining)   where-    indexedValues :: [(Int, Value)]-    indexedValues = zip [0..] (V.toList xs)--    itemFailures :: [Fail (ItemsInvalid err)]-    itemFailures = join (zipWith g subSchemas indexedValues)-      where-        g :: schema -> (Int, Value) -> [Fail (ItemsInvalid err)]-        g schema (index,x) = fmap Items-                           . prependToPath (AP.Token (T.pack (show index)))-                         <$> f schema x--    additionalItemFailures :: [Fail (ItemsInvalid err)]-    additionalItemFailures =-        case mAdditional of-            Nothing  -> mempty-            Just adi -> fmap correctName-                      . correctIndexes-                    <$> additionalItems f adi extras-      where-        -- It's not great that we convert back to Vector again.-        extras :: Vector Value-        extras = V.fromList . fmap snd-               . drop (length subSchemas) $ indexedValues--        -- Since 'additionalItems' only sees part of the array, but starts-        -- indexing from zero, we need to modify the paths it reports to-        -- represent invalid data so they actually represent the correct-        -- offsets.-        correctIndexes-          :: Fail (AdditionalItemsInvalid err)-          -> Fail (AdditionalItemsInvalid err)-        correctIndexes (Failure a b c d) = Failure a b (fixIndex c) d-          where-            fixIndex :: AP.Pointer -> AP.Pointer-            fixIndex (AP.Pointer (tok:toks)) =-                case readMaybe . T.unpack . AP._unToken $ tok of-                    Nothing -> AP.Pointer $ tok:toks-                    Just n  -> AP.Pointer $-                        (AP.Token . T.pack . show $ n + length subSchemas):toks-            fixIndex (AP.Pointer []) = AP.Pointer []+    indexed :: [(JP.Index, Value)]+    indexed = zip (JP.Index <$> [0..]) (V.toList xs) -        correctName :: AdditionalItemsInvalid err -> ItemsInvalid err-        correctName AdditionalBoolInvalid = AdditionalItemsBoolInvalid-        correctName (AdditionalObjectInvalid err) =-            AdditionalItemsObjectInvalid err+    validateElem+        :: schema+        -> (JP.Index, Value)+        -> Maybe (JP.Index, NonEmpty err)+    validateElem schema (index,x) = (index,) <$> NE.nonEmpty (f schema x)  -------------------------------------------------- -- * additionalItems --------------------------------------------------  data AdditionalItems schema-    = AdditionalBool Bool+    = AdditionalBool   Bool     | AdditionalObject schema     deriving (Eq, Show) @@ -160,25 +199,26 @@                       ]  data AdditionalItemsInvalid err-    = AdditionalBoolInvalid-    | AdditionalObjectInvalid err+    = AdditionalItemsBoolInvalid   (NonEmpty (JP.Index, Value))+    | AdditionalItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err))     deriving (Eq, Show) -additionalItems+-- | Internal.+--+-- This is because 'itemsRelated' handles @"additionalItems"@ validation.+additionalItemsVal     :: forall err schema.-       (schema -> Value -> [Fail err])+       (schema -> Value -> [err])     -> AdditionalItems schema-    -> Vector Value-    -> [Fail (AdditionalItemsInvalid err)]-additionalItems _ (AdditionalBool b) xs-    | b               = mempty-    | V.length xs > 0 = pure (Failure AdditionalBoolInvalid (Bool b)-                                      mempty (toJSON xs))-    | otherwise       = mempty-additionalItems f (AdditionalObject subSchema) xs =-    zip [0..] (V.toList xs) >>= g-  where-    g :: (Int, Value) -> [Fail (AdditionalItemsInvalid err)]-    g (index,x) = fmap AdditionalObjectInvalid-                . prependToPath (AP.Token (T.pack (show index)))-              <$> f subSchema x+    -> [(JP.Index, Value)]+       -- ^ The elements remaining to validate after the ones covered by+       -- @"items"@ have been removed.+    -> Maybe (AdditionalItemsInvalid err)+additionalItemsVal _ (AdditionalBool True) _ = Nothing+additionalItemsVal _ (AdditionalBool False) xs =+    AdditionalItemsBoolInvalid <$> NE.nonEmpty xs+additionalItemsVal f (AdditionalObject subSchema) xs =+    let res = mapMaybe+                  (\(index,x) -> (index,) <$> NE.nonEmpty (f subSchema x))+                  xs+    in AdditionalItemsObjectInvalid <$> NE.nonEmpty res

@@ -2,64 +2,83 @@ module Data.Validator.Draft4.Number where  import           Import-import           Prelude -import           Data.Fixed             (mod')-import           Data.Scientific        (Scientific)--import           Data.Validator.Failure (Fail(..))+import           Data.Fixed      (mod')+import           Data.Scientific (Scientific)  -------------------------------------------------- -- * multipleOf -------------------------------------------------- +newtype MultipleOf+    = MultipleOf { _unMultipleOf :: Scientific }+    deriving (Eq, Show)++instance FromJSON MultipleOf where+    parseJSON = withObject "MultipleOf" $ \o ->+        MultipleOf <$> o .: "multipleOf"++data MultipleOfInvalid+    = MultipleOfInvalid MultipleOf Scientific+    deriving (Eq, Show)+ -- | The spec requires @"multipleOf"@ to be positive.-multipleOf :: Scientific -> Scientific -> Maybe (Fail ())-multipleOf n x+multipleOfVal :: MultipleOf -> Scientific -> Maybe MultipleOfInvalid+multipleOfVal a@(MultipleOf n) x     | n <= 0          = Nothing-    | x `mod'` n /= 0 = Just (Failure () (toJSON n) mempty (Number x))+    | x `mod'` n /= 0 = Just (MultipleOfInvalid a x)     | otherwise       = Nothing  -------------------------------------------------- -- * maximum -------------------------------------------------- +data Maximum = Maximum+    { _maximumExclusive :: Bool+    , _maximumValue     :: Scientific+    } deriving (Eq, Show)++instance FromJSON Maximum where+    parseJSON = withObject "Maximum" $ \o -> Maximum+        <$> o .:! "exclusiveMaximum" .!= False+        <*> o .: "maximum"+ data MaximumInvalid-    = Maximum-    | ExclusiveMaximum+    = MaximumInvalid Maximum Scientific     deriving (Eq, Show)  maximumVal-    :: Bool-    -> Scientific+    :: Maximum     -> Scientific-    -> Maybe (Fail MaximumInvalid)-maximumVal exclusive n x-    | x `greaterThan` n = Just (Failure err (toJSON n) mempty (Number x))-    | otherwise         = Nothing-  where-    (greaterThan, err) = if exclusive-                             then ((>=), ExclusiveMaximum)-                             else ((>), Maximum)+    -> Maybe MaximumInvalid+maximumVal a@(Maximum exclusive n) x+    | exclusive && x >= n = Just (MaximumInvalid a x)+    | x > n               = Just (MaximumInvalid a x)+    | otherwise           = Nothing  -------------------------------------------------- -- * minimum -------------------------------------------------- +data Minimum = Minimum+    { _minimumExclusive :: Bool+    , _minimumValue     :: Scientific+    } deriving (Eq, Show)++instance FromJSON Minimum where+    parseJSON = withObject "Minimum" $ \o -> Minimum+        <$> o .:! "exclusiveMinimum" .!= False+        <*> o .: "minimum"+ data MinimumInvalid-    = Minimum-    | ExclusiveMinimum+    = MinimumInvalid Minimum Scientific     deriving (Eq, Show)  minimumVal-    :: Bool-    -> Scientific+    :: Minimum     -> Scientific-    -> Maybe (Fail MinimumInvalid)-minimumVal exclusive n x-    | x `lessThan` n = Just (Failure err (toJSON n) mempty (Number x))-    | otherwise      = Nothing-  where-    (lessThan, err) = if exclusive-                          then ((<=), ExclusiveMinimum)-                          else ((<), Minimum)+    -> Maybe MinimumInvalid+minimumVal a@(Minimum exclusive n) x+    | exclusive && x <= n = Just (MinimumInvalid a x)+    | x < n               = Just (MinimumInvalid a x)+    | otherwise           = Nothing

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Data.Validator.Draft4.Object   ( module Data.Validator.Draft4.Object@@ -6,41 +5,67 @@   ) where  import           Import--- Hiding is for GHCs before 7.10:-import           Prelude                                 hiding (all, concat,-                                                          foldl) -import           Data.Aeson.Types                        (Parser)-import qualified Data.HashMap.Strict                     as H+import qualified Data.HashMap.Strict                     as HM+import qualified Data.List.NonEmpty                      as NE import           Data.Set                                (Set) import qualified Data.Set                                as S import qualified Data.Text                               as T  import           Data.Validator.Draft4.Object.Properties-import           Data.Validator.Failure                  (Fail(..)) import           Data.Validator.Utils  -------------------------------------------------- -- * maxProperties -------------------------------------------------- +newtype MaxProperties+    = MaxProperties { _unMaxProperties :: Int }+    deriving (Eq, Show)++instance FromJSON MaxProperties where+    parseJSON = withObject "MaxProperties" $ \o ->+        MaxProperties <$> o .: "maxProperties"++data MaxPropertiesInvalid+    = MaxPropertiesInvalid MaxProperties (HashMap Text Value)+    deriving (Eq, Show)+ -- | The spec requires @"maxProperties"@ to be non-negative.-maxProperties :: Int -> HashMap Text Value -> Maybe (Fail ())-maxProperties n x-    | n < 0        = Nothing-    | H.size x > n = Just (Failure () (toJSON n) mempty (Object x))-    | otherwise    = Nothing+maxPropertiesVal+    :: MaxProperties+    -> HashMap Text Value+    -> Maybe MaxPropertiesInvalid+maxPropertiesVal a@(MaxProperties n) x+    | n < 0         = Nothing+    | HM.size x > n = Just (MaxPropertiesInvalid a x)+    | otherwise     = Nothing  -------------------------------------------------- -- * minProperties -------------------------------------------------- +newtype MinProperties+    = MinProperties { _unMinProperties :: Int }+    deriving (Eq, Show)++instance FromJSON MinProperties where+    parseJSON = withObject "MinProperties" $ \o ->+        MinProperties <$> o .: "minProperties"++data MinPropertiesInvalid+    = MinPropertiesInvalid MinProperties (HashMap Text Value)+    deriving (Eq, Show)+ -- | The spec requires @"minProperties"@ to be non-negative.-minProperties :: Int -> HashMap Text Value -> Maybe (Fail ())-minProperties n x-    | n < 0        = Nothing-    | H.size x < n = Just (Failure () (toJSON n) mempty (Object x))-    | otherwise    = Nothing+minPropertiesVal+    :: MinProperties+    -> HashMap Text Value+    -> Maybe MinPropertiesInvalid+minPropertiesVal a@(MinProperties n) x+    | n < 0         = Nothing+    | HM.size x < n = Just (MinPropertiesInvalid a x)+    | otherwise     = Nothing  -------------------------------------------------- -- * required@@ -51,28 +76,13 @@ -- > The value of this keyword MUST be an array. -- > This array MUST have at least one element. -- > Elements of this array MUST be strings, and MUST be unique.------ We don't enfore that 'Required' has at least one element in the--- haskell code, but we do in the 'FromJSON' instance. newtype Required     = Required { _unRequired :: Set Text }-    deriving (Eq, Show, ToJSON)+    deriving (Eq, Show)  instance FromJSON Required where-    parseJSON v = checkUnique =<< checkSize =<< parseJSON v-      where-        checkSize :: [Text] -> Parser [Text]-        checkSize a-            | null a    = fail "Required validator must not be empty."-            | otherwise = pure a--        checkUnique :: [Text] -> Parser Required-        checkUnique a =-            let b = S.fromList a-            -- NOTE: Can use length instead of S.size in GHC 7.10 or later.-            in if length a == S.size b-                then pure (Required b)-                else fail "All elements of the Required validator must be unique."+    parseJSON = withObject "Required" $ \o ->+        Required <$> o .: "required"  instance Arbitrary Required where     arbitrary = do@@ -80,23 +90,31 @@         xs <- (fmap.fmap) T.pack arbitrary         pure . Required . S.fromList $ x:xs -required :: Required -> HashMap Text Value -> Maybe (Fail ())-required (Required ts) x+requiredVal :: Required -> HashMap Text Value -> Maybe ()+requiredVal (Required ts) x     -- NOTE: When we no longer need to support GHCs before 7.10     -- we can use null from Prelude throughout the library     -- instead of specialized versions.-    | S.null ts                  = Nothing-    | H.null (H.difference hm x) = Nothing-    | otherwise                  = Just (Failure () (toJSON ts)-                                                 mempty (Object x))+    | S.null ts                    = Nothing+    | HM.null (HM.difference hm x) = Nothing+    | otherwise                    = Just () -- TODO   where     hm :: HashMap Text Bool-    hm = foldl (\b a -> H.insert a True b) mempty ts+    hm = foldl (\b a -> HM.insert a True b) mempty ts  -------------------------------------------------- -- * dependencies -------------------------------------------------- +newtype DependenciesValidator schema+    = DependenciesValidator+        { _unDependenciesValidator :: HashMap Text (Dependency schema) }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (DependenciesValidator schema) where+    parseJSON = withObject "DependenciesValidator" $ \o ->+        DependenciesValidator <$> o .: "dependencies"+ data Dependency schema     = SchemaDependency schema     | PropertyDependency (Set Text)@@ -115,11 +133,15 @@                       , PropertyDependency <$> arbitrarySetOfText                       ] -data DependencyInvalid err-    = SchemaDependencyInvalid err-    | PropertyDependencyInvalid+data DependencyMemberInvalid err+    = SchemaDepInvalid   (NonEmpty err)+    | PropertyDepInvalid (Set Text) (HashMap Text Value)     deriving (Eq, Show) +data DependenciesInvalid err+    = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err))+    deriving (Eq, Show)+ -- | From the spec: -- <http://json-schema.org/latest/json-schema-validation.html#anchor70> --@@ -132,26 +154,26 @@ -- > If the value is an array, it MUST have at least one element. -- > Each element MUST be a string, and elements in the array MUST be unique. -- > This is called a property dependency.-dependencies+dependenciesVal     :: forall err schema.-       (schema -> Value -> [Fail err])-    -> HashMap Text (Dependency schema)+       (schema -> Value -> [err])+    -> DependenciesValidator schema     -> HashMap Text Value-    -> [Fail (DependencyInvalid err)]-dependencies f hm x = concat . fmap (uncurry g) . H.toList $ hm-  where-    g :: Text -> Dependency schema -> [Fail (DependencyInvalid err)]-    g k (SchemaDependency schema)-        | H.member k x =-            fmap SchemaDependencyInvalid <$> f schema (Object x)-        | otherwise    = mempty-    g k (PropertyDependency ts)-        | H.member k x && not allPresent =-            pure $ Failure PropertyDependencyInvalid-                           (toJSON (H.singleton k ts))-                           mempty-                           (Object x)-        | otherwise = mempty-      where-        allPresent :: Bool-        allPresent = all (`H.member` x) ts+    -> Maybe (DependenciesInvalid err)+dependenciesVal f (DependenciesValidator hm) x =+    let res = HM.mapMaybeWithKey g hm+    in if HM.null res+        then Nothing+        else Just (DependenciesInvalid res)+    where+      g :: Text -> Dependency schema -> Maybe (DependencyMemberInvalid err)+      g k (SchemaDependency schema)+          | HM.member k x = SchemaDepInvalid+                        <$> NE.nonEmpty (f schema (Object x))+          | otherwise = Nothing+      g k (PropertyDependency ts)+          | HM.member k x && not allPresent = Just (PropertyDepInvalid ts x)+          | otherwise                       = Nothing+        where+          allPresent :: Bool+          allPresent = all (`HM.member` x) ts

@@ -2,213 +2,208 @@ module Data.Validator.Draft4.Object.Properties where  import           Import-import           Prelude -import           Control.Monad-import qualified Data.Aeson.Pointer     as AP-import           Data.Functor           (($>))-import qualified Data.HashMap.Strict    as HM-import           Data.Text.Encoding     (encodeUtf8)-import qualified Text.Regex.PCRE.Heavy  as RE+import qualified Data.Hashable         as HA+import qualified Data.HashMap.Strict   as HM+import qualified Data.List.NonEmpty    as NE+import           Data.Text.Encoding    (encodeUtf8)+import qualified JSONPointer           as JP+import qualified Text.Regex.PCRE.Heavy as RE -import           Data.Validator.Failure (Fail(..), prependToPath)+data PropertiesRelated schema = PropertiesRelated+    { _propProperties :: Maybe (HashMap Text schema)+    , _propPattern    :: Maybe (HashMap Text schema)+    , _propAdditional :: Maybe (AdditionalProperties schema)+    } deriving (Eq, Show) --- | For internal use.-newtype Remaining-    = Remaining { _unRemaining :: HashMap Text Value }+instance FromJSON schema => FromJSON (PropertiesRelated schema) where+    parseJSON = withObject "PropertiesRelated" $ \o -> PropertiesRelated+        <$> o .:! "properties"+        <*> o .:! "patternProperties"+        <*> o .:! "additionalProperties" ------------------------------------------------------ * properties---------------------------------------------------+emptyProperties :: PropertiesRelated schema+emptyProperties = PropertiesRelated+    { _propProperties = Nothing+    , _propPattern    = Nothing+    , _propAdditional = Nothing+    } -data PropertiesInvalid err-    = PropertiesInvalid err-    | PropPatternInvalid err-    | PropAdditionalInvalid (AdditionalPropertiesInvalid err)+data AdditionalProperties schema+    = AdditionalPropertiesBool Bool+    | AdditionalPropertiesObject schema     deriving (Eq, Show) --- | In order of what's tried: @"properties"@, @"patternProperties"@,--- @"additionalProperties"@.-properties-    :: forall err schema.-       (schema -> Value -> [Fail err])-    -> Maybe (HashMap Text schema)-    -> Maybe (AdditionalProperties schema)-    -> HashMap Text schema-    -> HashMap Text Value-    -> [Fail (PropertiesInvalid err)]-properties f mPat mAdd propertiesHm x =-       fmap (fmap PropertiesInvalid) propFailures-    <> fmap (fmap PropPatternInvalid) patternFailures-    <> fmap (fmap PropAdditionalInvalid) additionalFailures-  where-    propertiesAndUnmatched :: ([Fail err], Remaining)-    propertiesAndUnmatched = ( failures-                             , Remaining (HM.difference x propertiesHm)-                             )-      where-        failures :: [Fail err]-        failures = HM.toList (HM.intersectionWith f propertiesHm x)-               >>= (\(k,vs) -> fmap (prependToPath (AP.Token k)) vs)--    (propFailures, remaining1) = propertiesAndUnmatched+instance FromJSON schema => FromJSON (AdditionalProperties schema) where+    parseJSON v = fmap AdditionalPropertiesBool (parseJSON v)+              <|> fmap AdditionalPropertiesObject (parseJSON v) -    mPatProp :: Maybe (HashMap Text Value -> ([Fail err], Remaining))-    mPatProp = patternAndUnmatched f <$> mPat+instance ToJSON schema => ToJSON (AdditionalProperties schema) where+    toJSON (AdditionalPropertiesBool b)    = toJSON b+    toJSON (AdditionalPropertiesObject hm) = toJSON hm -    patternFailures :: [Fail err]-    patternFailures = case mPatProp of-                          Nothing  -> mempty-                          Just val -> fst (val x)+instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where+    arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary+                      , AdditionalPropertiesObject <$> arbitrary+                      ] -    remaining2 :: Remaining-    remaining2 = case mPatProp of-                     Nothing  -> remaining1-                     Just val -> snd . val . _unRemaining $ remaining1+-- | A glorified @type@ alias.+newtype Regex+    = Regex { _unRegex :: Text }+    deriving (Eq, Show, Generic) -    additionalFailures :: [Fail (AdditionalPropertiesInvalid err)]-    additionalFailures =-        case mAdd of-            Nothing -> mempty-            Just a  -> additionalProperties f True a (_unRemaining remaining2)+instance HA.Hashable Regex ------------------------------------------------------ * patternProperties---------------------------------------------------+-- NOTE: We'd like to enforce that at least one error exists here.+data PropertiesRelatedInvalid err = PropertiesRelatedInvalid+    { _prInvalidProperties :: HashMap Text [err]+    , _prInvalidPattern    :: HashMap (Regex, JP.Key) [err]+    , _prInvalidAdditional :: Maybe (APInvalid err)+    } deriving (Eq, Show) -data PatternPropertiesInvalid err-    = PPInvalid err-    | PPAdditionalPropertiesInvalid (AdditionalPropertiesInvalid err)+data APInvalid err+    = APBoolInvalid   (HashMap Text Value)+    | APObjectInvalid (HashMap Text (NonEmpty err))     deriving (Eq, Show) -patternProperties+-- | First @"properties"@ and @"patternProperties"@ are run simultaneously+-- on the data, then @"additionalProperties"@ is run on the remainder.+propertiesRelatedVal     :: forall err schema.-       (schema -> Value -> [Fail err])-    -> Bool-    -> Maybe (AdditionalProperties schema)-    -> HashMap Text schema+       (schema -> Value -> [err])+    -> PropertiesRelated schema     -> HashMap Text Value-    -> [Fail (PatternPropertiesInvalid err)]-patternProperties _ False _ _ _ = mempty-patternProperties f _ mAdd patternPropertiesHm x =-       (fmap PPInvalid <$> ppFailures)-    <> (fmap PPAdditionalPropertiesInvalid <$> addFailures)+    -> Maybe (PropertiesRelatedInvalid err)+propertiesRelatedVal f props x+    |  all null (HM.elems propFailures)+    && all null (HM.elems patFailures)+    && isNothing addFailures = Nothing+    | otherwise =+        Just PropertiesRelatedInvalid+            { _prInvalidProperties = propFailures+            , _prInvalidPattern    = patFailures+            , _prInvalidAdditional = addFailures+            }   where-    patternProps :: ([Fail err], Remaining)-    patternProps = patternAndUnmatched f patternPropertiesHm x+    propertiesHm :: HashMap Text schema+    propertiesHm = fromMaybe mempty (_propProperties props) -    (ppFailures, remaining) = patternProps+    patHm :: HashMap Text schema+    patHm = fromMaybe mempty (_propPattern props) -    addFailures :: [Fail (AdditionalPropertiesInvalid err)]-    addFailures =-        case mAdd of-            Nothing -> mempty-            Just a  -> additionalProperties f True a (_unRemaining remaining)+    propAndUnmatched :: (HashMap Text [err], Remaining)+    propAndUnmatched = ( HM.intersectionWith f propertiesHm x+                       , Remaining (HM.difference x propertiesHm)+                       ) +    (propFailures, propRemaining) = propAndUnmatched++    patAndUnmatched :: (HashMap (Regex, JP.Key) [err], Remaining)+    patAndUnmatched = patternAndUnmatched f patHm x++    (patFailures, patRemaining) = patAndUnmatched++    finalRemaining :: Remaining+    finalRemaining = Remaining (HM.intersection (_unRemaining patRemaining)+                                                (_unRemaining propRemaining))++    addFailures :: Maybe (APInvalid err)+    addFailures = (\addProp -> additionalProperties f addProp finalRemaining)+              =<< _propAdditional props++-- | Internal.+newtype Remaining+    = Remaining { _unRemaining :: HashMap Text Value }++-- | Internal. patternAndUnmatched     :: forall err schema.-       (schema -> Value -> [Fail err])+       (schema -> Value -> [err])     -> HashMap Text schema     -> HashMap Text Value-    -> ([Fail err], Remaining)+    -> (HashMap (Regex, JP.Key) [err], Remaining) patternAndUnmatched f patPropertiesHm x =-    (HM.foldlWithKey' runVals mempty perhapsMatches, remaining)+    (HM.foldlWithKey' runMatches mempty perhapsMatches, remaining)   where-    perhapsMatches :: HashMap Text (Value, [schema])-    perhapsMatches = HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x+    -- @[(Regex, schema)]@ will have one item per match.+    perhapsMatches :: HashMap Text ([(Regex, schema)], Value)+    perhapsMatches =+        HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x       where         matchingSchemas             :: HashMap Text schema-            -> HashMap Text (Value, [schema])+            -> HashMap Text ([(Regex, schema)], Value)             -> Text             -> Value-            -> HashMap Text (Value, [schema])+            -> HashMap Text ([(Regex, schema)], Value)         matchingSchemas subSchemas acc k v =-            HM.insert k (v, HM.foldlWithKey' (checkKey k) mempty subSchemas) acc+            HM.insert k+                      (HM.foldlWithKey' (checkKey k) mempty subSchemas, v)+                      acc          checkKey             :: Text-            -> [schema]+            -> [(Regex, schema)]             -> Text             -> schema-            -> [schema]+            -> [(Regex, schema)]         checkKey k acc r subSchema =             case RE.compileM (encodeUtf8 r) mempty of                 Left _   -> acc                 Right re -> if k RE.=~ re-                                then pure subSchema <> acc+                                then (Regex r, subSchema) : acc                                 else acc -    runVals-        :: [Fail err]+    runMatches+        :: HashMap (Regex, JP.Key) [err]         -> Text-        -> (Value, [schema])-        -> [Fail err]-    runVals acc k (v,subSchemas) =-        (subSchemas >>= (\schema -> prependToPath (AP.Token k) <$> f schema v))-        <> acc+        -> ([(Regex, schema)], Value)+        -> HashMap (Regex, JP.Key) [err]+    runMatches acc k (matches,v) =+        foldr runMatch acc matches+      where+        runMatch+            :: (Regex, schema)+            -> HashMap (Regex, JP.Key) [err]+            -> HashMap (Regex, JP.Key) [err]+        runMatch (r,schema) = HM.insert (r, JP.Key k) (f schema v)      remaining :: Remaining-    remaining = Remaining . fmap fst . HM.filter (null . snd) $ perhapsMatches------------------------------------------------------- * additionalProperties-----------------------------------------------------data AdditionalProperties schema-    = AdditionalPropertiesBool Bool-    | AdditionalPropertiesObject schema-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (AdditionalProperties schema) where-    parseJSON v = fmap AdditionalPropertiesBool (parseJSON v)-              <|> fmap AdditionalPropertiesObject (parseJSON v)--instance ToJSON schema => ToJSON (AdditionalProperties schema) where-    toJSON (AdditionalPropertiesBool b)    = toJSON b-    toJSON (AdditionalPropertiesObject hm) = toJSON hm--instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where-    arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary-                      , AdditionalPropertiesObject <$> arbitrary-                      ]--data AdditionalPropertiesInvalid err-    = APBoolInvalid-    | APObjectInvalid err-    deriving (Eq, Show)+    remaining = Remaining . fmap snd . HM.filter (null . fst) $ perhapsMatches +-- Internal. additionalProperties     :: forall err schema.-       (schema -> Value -> [Fail err])-    -> Bool+       (schema -> Value -> [err])     -> AdditionalProperties schema-    -> HashMap Text Value-    -> [Fail (AdditionalPropertiesInvalid err)]-additionalProperties _ False _ _ = mempty-additionalProperties f _ a x =+    -> Remaining+    -> Maybe (APInvalid err)+additionalProperties f a x =     case a of         AdditionalPropertiesBool b ->-            ($> APBoolInvalid) <$> additionalPropertiesBool b x+            APBoolInvalid <$> additionalPropertiesBool b x         AdditionalPropertiesObject b ->-            fmap APObjectInvalid <$> additionalPropertiesObject f b x+            APObjectInvalid <$> additionalPropertiesObject f b x +-- | Internal. additionalPropertiesBool     :: Bool-    -> HashMap Text Value-    -> [Fail ()]-additionalPropertiesBool False x-    | HM.size x > 0 = pure $ Failure () (Bool False) mempty (Object x)-    | otherwise    = mempty-additionalPropertiesBool True _ = mempty+    -> Remaining+    -> Maybe (HashMap Text Value)+additionalPropertiesBool True _ = Nothing+additionalPropertiesBool False (Remaining x)+    | HM.size x > 0 = Just x+    | otherwise     = Nothing +-- | Internal. additionalPropertiesObject     :: forall err schema.-       (schema -> Value -> [Fail err])+       (schema -> Value -> [err])     -> schema-    -> HashMap Text Value-    -> [Fail err]-additionalPropertiesObject f schema x = HM.toList x >>= g-  where-    g :: (Text, Value) -> [Fail err]-    g (k,v) = prependToPath (AP.Token k) <$> f schema v+    -> Remaining+    -> Maybe (HashMap Text (NonEmpty err))+additionalPropertiesObject f schema (Remaining x) =+    let errs = HM.mapMaybe (NE.nonEmpty . f schema) x+    in if HM.null errs+        then Nothing+        else Just errs

@@ -2,44 +2,78 @@ module Data.Validator.Draft4.String where  import           Import-import           Prelude -import qualified Data.Text              as T-import           Data.Text.Encoding     (encodeUtf8)-import qualified Text.Regex.PCRE.Heavy  as RE--import           Data.Validator.Failure (Fail(..))+import qualified Data.Text             as T+import           Data.Text.Encoding    (encodeUtf8)+import qualified Text.Regex.PCRE.Heavy as RE  -------------------------------------------------- -- * maxLength -------------------------------------------------- +newtype MaxLength+    = MaxLength { _unMaxLength :: Int }+    deriving (Eq, Show)++instance FromJSON MaxLength where+    parseJSON = withObject "MaxLength" $ \o ->+        MaxLength <$> o .: "maxLength"++data MaxLengthInvalid+    = MaxLengthInvalid MaxLength Text+    deriving (Eq, Show)+ -- | The spec requires @"maxLength"@ to be non-negative.-maxLength :: Int -> Text -> Maybe (Fail ())-maxLength n x+maxLengthVal :: MaxLength -> Text -> Maybe MaxLengthInvalid+maxLengthVal a@(MaxLength n) x     | n <= 0         = Nothing-    | T.length x > n = Just (Failure () (toJSON n) mempty (String x))+    | T.length x > n = Just (MaxLengthInvalid a x)     | otherwise      = Nothing  -------------------------------------------------- -- * minLength -------------------------------------------------- +newtype MinLength+    = MinLength { _unMinLength :: Int }+    deriving (Eq, Show)++instance FromJSON MinLength where+    parseJSON = withObject "MinLength" $ \o ->+        MinLength <$> o .: "minLength"++data MinLengthInvalid+    = MinLengthInvalid MinLength Text+    deriving (Eq, Show)+ -- | The spec requires @"minLength"@ to be non-negative.-minLength :: Int -> Text -> Maybe (Fail ())-minLength n x+minLengthVal :: MinLength -> Text -> Maybe MinLengthInvalid+minLengthVal a@(MinLength n) x     | n <= 0         = Nothing-    | T.length x < n = Just (Failure () (toJSON n) mempty (String x))+    | T.length x < n = Just (MinLengthInvalid a x)     | otherwise      = Nothing  -------------------------------------------------- -- * pattern -------------------------------------------------- -patternVal :: Text -> Text -> Maybe (Fail ())-patternVal t x =+newtype PatternValidator+    = PatternValidator { _unPatternValidator :: Text }+    deriving (Eq, Show)++instance FromJSON PatternValidator where+    parseJSON = withObject "PatternValidator" $ \o ->+        PatternValidator <$> o .: "pattern"++data PatternInvalid+    = PatternNotRegex -- TODO: let these pass successfully?+    | PatternInvalid PatternValidator Text+    deriving (Eq, Show)++patternVal :: PatternValidator -> Text -> Maybe PatternInvalid+patternVal a@(PatternValidator t) x =     case RE.compileM (encodeUtf8 t) mempty of-        Left _   -> Just (Failure () (toJSON t) mempty (String x))+        Left _   -> Just PatternNotRegex         Right re -> if x RE.=~ re                         then Nothing-                        else Just (Failure () (toJSON t) mempty (String x))+                        else Just (PatternInvalid a x)

@@ -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 }

@@ -7,14 +7,14 @@ module Data.Validator.Reference where  import           Import-import           Prelude -import qualified Data.Aeson.Pointer     as AP import qualified Data.Text              as T import           Data.Text.Encoding     (decodeUtf8, encodeUtf8)+import qualified JSONPointer            as JP import           Network.HTTP.Types.URI (urlDecode) import           System.FilePath        ((</>), dropFileName) +-- | TODO: Replace these with actual URI data types. type URIBase = Maybe Text type URIBaseAndFragment = (Maybe Text, Maybe Text) @@ -34,8 +34,8 @@ resolveFragment Nothing schema        = Just schema resolveFragment (Just pointer) schema = do     let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer-    p <- either (const Nothing) Just (AP.unescape urlDecoded)-    x <- either (const Nothing) Just (AP.resolve p (toJSON schema))+    p <- either (const Nothing) Just (JP.unescape urlDecoded)+    x <- either (const Nothing) Just (JP.resolve p (toJSON schema))     case fromJSON x of         Error _         -> Nothing         Success schema' -> Just schema'

@@ -1,13 +1,9 @@-{-# LANGUAGE DeriveFunctor #-}  module Data.Validator.Types where -import           Prelude--import           Data.Aeson             (Value)-import           Data.Profunctor        (Profunctor(..))+import           Import -import           Data.Validator.Failure (Fail)+import           Data.Profunctor (Profunctor(..))  data Validator schema val err = Validator     { _embedded :: val -> ([schema], [schema])@@ -19,7 +15,7 @@       -- This is done to allow static detection of loops, though this isn't       -- implemented yet (though the Draft4 code does do live loop detection       -- during validation).-    , _validate :: val -> Value -> [Fail err]+    , _validate :: val -> Value -> [err]     } deriving Functor  instance Profunctor (Validator schema) where

@@ -2,11 +2,9 @@ module Data.Validator.Utils where  import           Import-import           Prelude -import           Control.Arrow+import           Control.Monad        (fail) import qualified Data.HashMap.Strict  as HM-import           Data.List.NonEmpty   (NonEmpty) import qualified Data.List.NonEmpty   as NE import           Data.Scientific      (Scientific, fromFloatDigits) import           Data.Set             (Set)

@@ -1,12 +1,12 @@  module Import (module Export) where -import           Control.Applicative as Export+import           Protolude           as Export+ import           Data.Aeson          as Export-import           Data.Foldable       as Export import           Data.HashMap.Strict as Export (HashMap)-import           Data.Monoid         as Export-import           Data.Text           as Export (Text)-import           Data.Traversable    as Export+import           Data.List           as Export (length, null) -- for older GHCs+import           Data.List.NonEmpty  as Export (NonEmpty) import           Data.Vector         as Export (Vector)-import           Test.QuickCheck     as Export hiding (Failure, Result, Success)+import           Test.QuickCheck     as Export hiding ((.&.), Failure,+                                                       Result, Success)

@@ -1,18 +1,17 @@  module Main where -import           Control.Applicative-import           Control.Monad          (unless)+import           Protolude+ import           Data.Aeson-import           Data.Foldable          (traverse_)-import qualified Data.List.NonEmpty     as N-import           Data.Monoid+import qualified Data.List.NonEmpty     as NE import qualified System.Timeout         as TO import           Test.Hspec import           Test.QuickCheck        (property)  import qualified Data.JsonSchema.Draft4 as D4-import           Data.JsonSchema.Fetch  (ReferencedSchemas(..))+import           Data.JsonSchema.Fetch  (ReferencedSchemas(..),+                                         URISchemaMap(..)) import qualified Data.JsonSchema.Types  as JT import qualified Local.Failure import qualified Local.Validation@@ -21,13 +20,13 @@  -- Examples import qualified AlternateSchema-import qualified Full import qualified Simple+import qualified TwoStep -dir :: String+dir :: FilePath dir = "JSON-Schema-Test-Suite/tests/draft4" -supplementDir :: String+supplementDir :: FilePath supplementDir = "test/supplement"  main :: IO ()@@ -73,22 +72,20 @@         res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc)         let failures = case res of                            Right ()           -> mempty-                           Left (D4.HVData a) -> N.toList a-                           other              -> error ("Local.validate error: "+                           Left (D4.HVData a) -> NE.toList (D4._invalidFailures a)+                           other              -> panic ("Local.validate error: "                                                        <> show other)-        traverse_ (checkPointer (_scData sc)) failures         assertResult sc failures      validateExample :: JT.Schema -> SchemaTestCase -> Expectation     validateExample s sc = do         res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing)         case res of-            Left e          -> error ("Local.validateExample error: " <> show e)+            Left e          -> panic ("Local.validateExample error: " <> show e)             Right schemaMap -> do                 let failures = AlternateSchema.validate-                                   (ReferencedSchemas s schemaMap)+                                   (ReferencedSchemas s (_unURISchemaMap schemaMap))                                    Nothing s (_scData sc)-                traverse_ (checkPointer (_scData sc)) failures                 assertResult sc failures  quickCheckTests :: Spec@@ -101,5 +98,5 @@  exampleTests :: Spec exampleTests = do-    it "Full.example compiles successfully" Full.example     it "Simple.example compiles successfully" Simple.example+    it "TwoStep.example compiles successfully" TwoStep.example

@@ -1,35 +1,41 @@  module Local.Failure where -import           Prelude+import           Protolude  import           Data.Aeson-import qualified Data.Aeson.Pointer          as P-import           Data.Monoid import           Test.Hspec+import qualified Data.Vector                 as V+import qualified JSONPointer                 as JP  import           Data.JsonSchema.Draft4-import           Data.JsonSchema.Draft4.Spec (validate)-import qualified Data.Validator.Draft4.Array as AR+import qualified Data.JsonSchema.Draft4.Spec as Spec+import qualified Data.Validator.Draft4       as D4  spec :: Spec spec = do     it "items array failures are constructed correctly" itemsArray     it "items object failures are constructed correctly" itemsObject+    it "reports infinitely looping references correctly" loopRef  itemsArray :: Expectation itemsArray =     failures `shouldBe`-        [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"])-                 (toJSON [True, True])+        [ FailureItems (D4.ItemsArrayInvalid (+            pure ( JP.Index 0+                 , pure (FailureUniqueItems (D4.UniqueItemsInvalid+                       (V.fromList [Null, Null])+                   ))+                 )+          ))         ]   where-    failures = validate (ReferencedSchemas schema mempty)-                        sw (toJSON [[True, True]])+    failures :: [ValidatorFailure]+    failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData      schema :: Schema     schema = emptySchema-        { _schemaItems = Just $ AR.ItemsArray+        { _schemaItems = Just $ D4.ItemsArray             [emptySchema { _schemaUniqueItems = Just True }]         } @@ -39,19 +45,27 @@         , _swURI    = Nothing         } +    badData :: Value+    badData = toJSON [[Null, Null]]+ itemsObject :: Expectation itemsObject =     failures `shouldBe`-        [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"])-                 (toJSON [True, True])+        [ FailureItems (D4.ItemsObjectInvalid (+            pure ( JP.Index 1+                 , pure (FailureUniqueItems (D4.UniqueItemsInvalid+                       (V.fromList [Null, Null])+                   ))+                 )+          ))         ]   where-    failures = validate (ReferencedSchemas schema mempty)-                        sw (toJSON [[True, True]])+    failures :: [ValidatorFailure]+    failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData      schema :: Schema     schema = emptySchema-        { _schemaItems = Just $ AR.ItemsObject+        { _schemaItems = Just $ D4.ItemsObject             (emptySchema { _schemaUniqueItems = Just True })         } @@ -60,3 +74,33 @@         { _swSchema = schema         , _swURI    = Nothing         }++    badData :: Value+    badData = toJSON [Null, toJSON [Null, Null]]++loopRef :: Expectation+loopRef =+    failures `shouldBe`+        [ FailureRef (D4.RefLoop+            "#"+            (D4.VisitedSchemas [(Nothing, Nothing)])+            (Nothing, Nothing)+          )+        ]+  where+    failures :: [ValidatorFailure]+    failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData++    schema :: Schema+    schema = emptySchema+        { _schemaRef = Just "#"+        }++    sw :: SchemaWithURI Schema+    sw = SchemaWithURI+        { _swSchema = schema+        , _swURI    = Nothing+        }++    badData :: Value+    badData = toJSON [[Null, Null]]

@@ -1,6 +1,8 @@  module Local.Reference where +import           Protolude+ import           Test.Hspec  import           Data.Validator.Reference

@@ -1,12 +1,12 @@  module Local.Validation where -import           Control.Applicative+import           Protolude              hiding (msg)+ import           Data.Aeson import qualified Data.Aeson             as AE import qualified Data.HashMap.Strict    as HM-import           Data.Monoid-import           Data.Text              (Text)+import           Data.String            (String) import           Test.Hspec  import           Data.JsonSchema.Draft4

@@ -1,25 +1,25 @@  module Main where -import           Control.Applicative+import           Protolude+ import           Control.Concurrent.Async       (withAsync)-import           Data.Foldable                  (traverse_)-import qualified Data.List.NonEmpty             as N-import           Data.Monoid+import qualified Data.List.NonEmpty             as NE import           Network.Wai.Application.Static (defaultFileServerSettings,                                                  staticApp) import           Network.Wai.Handler.Warp       (run) import           Test.Hspec  import qualified Data.JsonSchema.Draft4         as D4-import           Data.JsonSchema.Fetch          (ReferencedSchemas(..))+import           Data.JsonSchema.Fetch          (ReferencedSchemas(..),+                                                URISchemaMap(..)) import qualified Data.JsonSchema.Types          as JT import           Shared  -- Examples import qualified AlternateSchema -dir :: String+dir :: FilePath dir = "JSON-Schema-Test-Suite/tests/draft4"  main :: IO ()@@ -36,22 +36,20 @@         res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc)         let failures = case res of                            Right ()           -> mempty-                           Left (D4.HVData a) -> N.toList a-                           other              -> error ("Local.validate error: "+                           Left (D4.HVData a) -> NE.toList (D4._invalidFailures a)+                           other              -> panic ("Local.validate error: "                                                        <> show other)-        traverse_ (checkPointer (_scData sc)) failures         assertResult sc failures      validateExample :: JT.Schema -> SchemaTestCase -> Expectation     validateExample s sc = do         res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing)         case res of-            Left e          -> error ("Remote.validateExample error: " <> show e)+            Left e          -> panic ("Remote.validateExample error: " <> show e)             Right schemaMap -> do                 let failures = AlternateSchema.validate-                                   (ReferencedSchemas s schemaMap)+                                   (ReferencedSchemas s (_unURISchemaMap schemaMap))                                    Nothing s (_scData sc)-                traverse_ (checkPointer (_scData sc)) failures                 assertResult sc failures  serve :: IO ()

@@ -1,29 +1,19 @@-{-# LANGUAGE DeriveGeneric #-}  module Shared where -import           Control.Applicative-import           Control.Monad+import           Protolude++import           Control.Monad        (fail) import           Data.Aeson-import qualified Data.Aeson.Pointer     as AP import           Data.Aeson.TH-import qualified Data.ByteString.Lazy   as LBS-import           Data.Char              (toLower)-import qualified Data.HashMap.Strict    as HM-import           Data.List              (isInfixOf, stripPrefix)-import           Data.Maybe-import           Data.Monoid-import           Data.Text              (Text)-import qualified Data.Text              as T-import           Data.Traversable-import qualified Data.Vector            as V-import           GHC.Generics-import qualified System.Directory       as SD-import           System.FilePath        ((</>))+import qualified Data.ByteString.Lazy as LBS+import           Data.Char            (toLower)+import           Data.List            (stripPrefix, unlines)+import qualified Data.Text            as T+import qualified System.Directory     as SD+import           System.FilePath      ((</>)) import           Test.Hspec -import qualified Data.JsonSchema.Draft4 as D4- -- Recursively return the contents of a directory -- (or return itself if given a file as an argument). --@@ -47,35 +37,14 @@             fs <- fmap (path </>) <$> SD.listDirectory path             concat <$> traverse listFilesFullPath fs -checkPointer :: Value -> D4.Failure -> Expectation-checkPointer v failure =-    case AP.resolve (D4._failureOffendingPointer failure) v of-        Left e  -> error ("Couldn't resolve pointer: " <> show e)-        Right a -> assertContains a (D4._failureOffendingData failure)-  where-    -- Some validators, such as 'additionalItems', only return a subset-    -- of the data incated by their '_failureOffendingPointer'.-    -- See the comments on 'Data.Validator.Failure.Failure' for more info.-    assertContains :: Value -> Value -> Expectation-    assertContains x y-        | x == y    = pure ()-        | otherwise =-            case (x,y) of-                (Array xs, Array ys) ->-                    V.toList ys `shouldSatisfy` (`isInfixOf` V.toList xs)-                (Object xhm, Object yhm) ->-                    HM.toList yhm `shouldSatisfy` (`isInfixOf` HM.toList xhm)-                _ -> expectationFailure-                        "Pointer resolution incorrect: result mismatch"--isHTTPTest :: String -> Bool+isHTTPTest :: FilePath -> Bool isHTTPTest file = (file == "definitions.json")                || (file == "ref.json")                || (file == "refRemote.json")  -- | We may never support the @"format"@ keywords, and -- are currently failing the zeroTerminatedFloats test.-skipOptional :: String -> Bool+skipOptional :: FilePath -> Bool skipOptional file = (file == "optional/format.json")                  || (file == "optional/zeroTerminatedFloats.json") @@ -104,9 +73,9 @@                     { fieldLabelModifier = fmap toLower . drop 3 }  readSchemaTests-    :: String+    :: FilePath     -- ^ The path to a directory.-    -> (String -> Bool)+    -> (FilePath -> Bool)     -- ^ A function to decide what we're interested in within that directory.     -> IO [SchemaTest] readSchemaTests dir filterFunc = do@@ -114,7 +83,7 @@     concat <$> traverse fileToCases files   where     -- Each file contains an array of SchemaTests, not just one.-    fileToCases :: String -> IO [SchemaTest]+    fileToCases :: FilePath -> IO [SchemaTest]     fileToCases name = do         let fullPath = dir </> name         jsonBS <- LBS.readFile fullPath@@ -122,7 +91,7 @@             Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e             Right schemaTests -> pure $ prependFileName name <$> schemaTests -    prependFileName :: String -> SchemaTest -> SchemaTest+    prependFileName :: FilePath -> SchemaTest -> SchemaTest     prependFileName fileName s = s         { _stDescription = T.pack fileName <> ": " <> _stDescription s         }@@ -138,15 +107,15 @@   where     schema :: schema     schema = case fromJSON (_stSchema st) of-                 Error e   -> error ("Couldn't parse schema: " <> show e)+                 Error e   -> panic ("Couldn't parse schema: " <> show e)                  Success a -> a -assertResult :: SchemaTestCase -> [D4.Failure] -> Expectation+assertResult :: Show err => SchemaTestCase -> [err] -> Expectation assertResult sc failures     | _scValid sc = assertValid sc failures     | otherwise   = assertInvalid sc failures -assertValid :: SchemaTestCase -> [D4.Failure] -> Expectation+assertValid :: Show err => SchemaTestCase -> [err] -> Expectation assertValid _ [] = pure () assertValid sc failures =     expectationFailure $ unlines@@ -156,7 +125,7 @@         , "    Validation failures: " <> show failures         ] -assertInvalid :: SchemaTestCase -> [D4.Failure] -> Expectation+assertInvalid :: SchemaTestCase -> [err] -> Expectation assertInvalid sc [] =     expectationFailure $ unlines         [ "    Validated invalid data"