hjsonschema 0.10.0.3 → 1.0.0.0

raw patch · 41 files changed

+3089/−1720 lines, 41 filesdep +profunctorsdep ~QuickCheckdep ~directorydep ~hjsonpointerPVP ok

version bump matches the API change (PVP)

Dependencies added: profunctors

Dependency ranges changed: QuickCheck, directory, hjsonpointer, http-client, semigroups, unordered-containers

API changes (from Hackage documentation)

Files

• JSON-Schema-Test-Suite/tests/draft4/optional/bignum.json +107/−0
• JSON-Schema-Test-Suite/tests/draft4/optional/format.json +148/−0
• JSON-Schema-Test-Suite/tests/draft4/optional/zeroTerminatedFloats.json +15/−0
• JSON-Schema-Test-Suite/tests/draft4/pattern.json +11/−0
• JSON-Schema-Test-Suite/tests/draft4/ref.json +18/−3
• JSON-Schema-Test-Suite/tests/draft4/type.json +2/−2
• README.md +7/−3
• changelog.txt +36/−0
• examples/AlternateSchema.hs +160/−0
• examples/CustomSchema.hs +0/−71
• examples/Full.hs +20/−14
• examples/PrettyShowFailure.hs +0/−53
• examples/Simple.hs +23/−25
• examples/json/start.json +3/−0
• hjsonschema.cabal +46/−22
• src/Data/JsonSchema/Draft4.hs +146/−97
• src/Data/JsonSchema/Draft4/Failure.hs +108/−43
• src/Data/JsonSchema/Draft4/Internal.hs +0/−267
• src/Data/JsonSchema/Draft4/Schema.hs +271/−267
• src/Data/JsonSchema/Draft4/Spec.hs +130/−0
• src/Data/JsonSchema/Fetch.hs +115/−94
• src/Data/JsonSchema/Types.hs +38/−0
• src/Data/Validator/Draft4.hs +549/−6
• src/Data/Validator/Draft4/Any.hs +148/−107
• src/Data/Validator/Draft4/Array.hs +110/−94
• src/Data/Validator/Draft4/Number.hs +48/−34
• src/Data/Validator/Draft4/Object.hs +80/−70
• src/Data/Validator/Draft4/Object/Properties.hs +139/−115
• src/Data/Validator/Draft4/String.hs +32/−19
• src/Data/Validator/Failure.hs +32/−25
• src/Data/Validator/Reference.hs +27/−39
• src/Data/Validator/Types.hs +27/−0
• src/Data/Validator/Utils.hs +52/−41
• test/Local.hs +94/−26
• test/Local/Failure.hs +40/−27
• test/Local/Filesystem.hs +0/−56
• test/Local/Reference.hs +35/−35
• test/Local/Validation.hs +82/−0
• test/Remote.hs +47/−9
• test/Shared.hs +126/−56
• test/supplement/recurse.json +17/−0

@@ -0,0 +1,107 @@+[+    {+        "description": "integer",+        "schema": {"type": "integer"},+        "tests": [+            {+                "description": "a bignum is an integer",+                "data": 12345678910111213141516171819202122232425262728293031,+                "valid": true+            }+        ]+    },+    {+        "description": "number",+        "schema": {"type": "number"},+        "tests": [+            {+                "description": "a bignum is a number",+                "data": 98249283749234923498293171823948729348710298301928331,+                "valid": true+            }+        ]+    },+    {+        "description": "integer",+        "schema": {"type": "integer"},+        "tests": [+            {+                "description": "a negative bignum is an integer",+                "data": -12345678910111213141516171819202122232425262728293031,+                "valid": true+            }+        ]+    },+    {+        "description": "number",+        "schema": {"type": "number"},+        "tests": [+            {+                "description": "a negative bignum is a number",+                "data": -98249283749234923498293171823948729348710298301928331,+                "valid": true+            }+        ]+    },+    {+        "description": "string",+        "schema": {"type": "string"},+        "tests": [+            {+                "description": "a bignum is not a string",+                "data": 98249283749234923498293171823948729348710298301928331,+                "valid": false+            }+        ]+    },+    {+        "description": "integer comparison",+        "schema": {"maximum": 18446744073709551615},+        "tests": [+            {+                "description": "comparison works for high numbers",+                "data": 18446744073709551600,+                "valid": true+            }+        ]+    },+    {+        "description": "float comparison with high precision",+        "schema": {+            "maximum": 972783798187987123879878123.18878137,+            "exclusiveMaximum": true+        },+        "tests": [+            {+                "description": "comparison works for high numbers",+                "data": 972783798187987123879878123.188781371,+                "valid": false+            }+        ]+    },+    {+        "description": "integer comparison",+        "schema": {"minimum": -18446744073709551615},+        "tests": [+            {+                "description": "comparison works for very negative numbers",+                "data": -18446744073709551600,+                "valid": true+            }+        ]+    },+    {+        "description": "float comparison with high precision on negative numbers",+        "schema": {+            "minimum": -972783798187987123879878123.18878137,+            "exclusiveMinimum": true+        },+        "tests": [+            {+                "description": "comparison works for very negative numbers",+                "data": -972783798187987123879878123.188781371,+                "valid": false+            }+        ]+    }+]

@@ -0,0 +1,148 @@+[+    {+        "description": "validation of date-time strings",+        "schema": {"format": "date-time"},+        "tests": [+            {+                "description": "a valid date-time string",+                "data": "1963-06-19T08:30:06.283185Z",+                "valid": true+            },+            {+                "description": "an invalid date-time string",+                "data": "06/19/1963 08:30:06 PST",+                "valid": false+            },+            {+                "description": "only RFC3339 not all of ISO 8601 are valid",+                "data": "2013-350T01:01:01",+                "valid": false+            }+        ]+    },+    {+        "description": "validation of URIs",+        "schema": {"format": "uri"},+        "tests": [+            {+                "description": "a valid URI",+                "data": "http://foo.bar/?baz=qux#quux",+                "valid": true+            },+            {+                "description": "a valid protocol-relative URI",+                "data": "//foo.bar/?baz=qux#quux",+                "valid": true+            },+            {+                "description": "an invalid URI",+                "data": "\\\\WINDOWS\\fileshare",+                "valid": false+            },+            {+                "description": "an invalid URI though valid URI reference",+                "data": "abc",+                "valid": false+            }+        ]+    },+    {+        "description": "validation of e-mail addresses",+        "schema": {"format": "email"},+        "tests": [+            {+                "description": "a valid e-mail address",+                "data": "joe.bloggs@example.com",+                "valid": true+            },+            {+                "description": "an invalid e-mail address",+                "data": "2962",+                "valid": false+            }+        ]+    },+    {+        "description": "validation of IP addresses",+        "schema": {"format": "ipv4"},+        "tests": [+            {+                "description": "a valid IP address",+                "data": "192.168.0.1",+                "valid": true+            },+            {+                "description": "an IP address with too many components",+                "data": "127.0.0.0.1",+                "valid": false+            },+            {+                "description": "an IP address with out-of-range values",+                "data": "256.256.256.256",+                "valid": false+            },+            {+                "description": "an IP address without 4 components",+                "data": "127.0",+                "valid": false+            },+            {+                "description": "an IP address as an integer",+                "data": "0x7f000001",+                "valid": false+            }+        ]+    },+    {+        "description": "validation of IPv6 addresses",+        "schema": {"format": "ipv6"},+        "tests": [+            {+                "description": "a valid IPv6 address",+                "data": "::1",+                "valid": true+            },+            {+                "description": "an IPv6 address with out-of-range values",+                "data": "12345::",+                "valid": false+            },+            {+                "description": "an IPv6 address with too many components",+                "data": "1:1:1:1:1:1:1:1:1:1:1:1:1:1:1:1",+                "valid": false+            },+            {+                "description": "an IPv6 address containing illegal characters",+                "data": "::laptop",+                "valid": false+            }+        ]+    },+    {+        "description": "validation of host names",+        "schema": {"format": "hostname"},+        "tests": [+            {+                "description": "a valid host name",+                "data": "www.example.com",+                "valid": true+            },+            {+                "description": "a host name starting with an illegal character",+                "data": "-a-host-name-that-starts-with--",+                "valid": false+            },+            {+                "description": "a host name containing illegal characters",+                "data": "not_a_valid_host_name",+                "valid": false+            },+            {+                "description": "a host name with a component too long",+                "data": "a-vvvvvvvvvvvvvvvveeeeeeeeeeeeeeeerrrrrrrrrrrrrrrryyyyyyyyyyyyyyyy-long-host-name-component",+                "valid": false+            }+        ]+    }+]

@@ -0,0 +1,15 @@+[+    {+        "description": "some languages do not distinguish between different types of numeric value",+        "schema": {+            "type": "integer"+        },+        "tests": [+            {+                "description": "a float is not an integer even without fractional part",+                "data": 1.0,+                "valid": false+            }+        ]+    }+]

@@ -19,5 +19,16 @@                 "valid": true             }         ]+    },+    {+        "description": "pattern is not anchored",+        "schema": {"pattern": "a+"},+        "tests": [+            {+                "description": "matches a substring",+                "data": "xxaayy",+                "valid": true+            }+        ]     } ]

@@ -86,19 +86,34 @@         },         "tests": [             {-                "description": "slash",+                "description": "slash invalid",                 "data": {"slash": "aoeu"},                 "valid": false             },             {-                "description": "tilda",+                "description": "tilda invalid",                 "data": {"tilda": "aoeu"},                 "valid": false             },             {-                "description": "percent",+                "description": "percent invalid",                 "data": {"percent": "aoeu"},                 "valid": false+            },+            {+                "description": "slash valid",+                "data": {"slash": 123},+                "valid": true+            },+            {+                "description": "tilda valid",+                "data": {"tilda": 123},+                "valid": true+            },+            {+                "description": "percent valid",+                "data": {"percent": 123},+                "valid": true             }         ]     },

@@ -188,7 +188,7 @@                 "valid": false             },             {-                "description": "an array is not an array",+                "description": "an array is an array",                 "data": [],                 "valid": true             },@@ -234,7 +234,7 @@                 "valid": false             },             {-                "description": "a boolean is not a boolean",+                "description": "a boolean is a boolean",                 "data": true,                 "valid": true             },

@@ -4,8 +4,10 @@  [Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema) -NOTE: You CANNOT use untrusted JSON data to make schemas. Schemas with circular references can cause infinite loops. See the issue list for more info.+Requires [pcre](http://www.pcre.org/) (`pkgs.pcre` in Nixpkgs). +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.+ # Example  See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Simple.hs).@@ -34,7 +36,7 @@  ## Good Parts -+ Passes all the tests in the [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite).++ Passes all the required tests in the [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite).  + Very modular, which should make it easy to support future versions of the specification. @@ -42,11 +44,13 @@  + Uses the [pcre-heavy](https://hackage.haskell.org/package/pcre-heavy) regular expression library for the "pattern" validator. It should use a library based on the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires. ++ Currently doesn't support the optional `"format"` validators.+ ## Notes  + `JSON-Schema-Test-Suite` is vendored from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite). -+ `src/draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema).++ `src/draft4.json` is from commit # f3d5aeb5ffbe9d9a5a0ceb761dc47c7c4c2efa68 [here](https://github.com/json-schema/json-schema).  ## Credits 

@@ -1,3 +1,39 @@+# 1.0.0.0++## Bug fixes:+++ Fix JSON Pointer bug. Pointers were being built in reverse order and so were+totally invalid.++ Use `.:!` instead of `.:?` to parse the draft 4 schema. The only way to omit+optional fields in JSON Schema Draft 4 is to omit them entirely, `"null"`+can't be used for this.++## API Changes:+++ Add referenced schema loop detection.++ Add a new `referencesValidity` function.++ `checkSchema` now checks referenced schema's validity in addition to the+starting schema's validity. This change bubbles up to the one-step validation+functions as well.++ Switch most of the fetching code to use `URISchemaMap` instead of+`ReferencedSchemas`. It didn't need to know about the more complicated data+type.++ Rething failure related names. Change `Invalid` to `Failure`, add a new+`Invalid` type alias which is only used for final results.++ Failures now include the failing part of the data as well as a JSON Pointer to+it, so you don't have to worry about resolving the pointer.++## Fundamental Changes:+++ Make `Fail` (previously `Failure`) an instance of `Functor`.++ Add a `Validator` data type which is an instance of `Profunctor`.++ Add a `Spec` data type for collections of `Validators`.++## General:+++ Switch from 2 to 4 space indentation.++ Update the vendored JSON Schema Test Suite.+ # 0.10.0.3  + Bump http-client.

@@ -0,0 +1,160 @@+-- | An implementation of JSON Schema Draft 4 based on 'HashMap Text Value'+-- instead of a custom record type like 'Data.JsonSchema.Draft4'.+--+-- If you're writing code for a new schema specification you probably want+-- to copy this module instead of the 'Data.JsonSchema.Draft4'. While it's+-- 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           Data.JsonSchema.Draft4         (schemaForSchemasBytes)+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)++--------------------------------------------------+-- * Basic fetching tools+--------------------------------------------------++referencesViaHTTP+    :: SchemaWithURI Schema+    -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema))+referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo++draft4FetchInfo :: FE.FetchInfo Schema+draft4FetchInfo = FE.FetchInfo embedded (get "id") (get "$ref")+  where+    get :: Text -> Schema -> Maybe Text+    get 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++--------------------------------------------------+-- * Main API+--------------------------------------------------++validate+    :: ReferencedSchemas Schema+    -> Maybe Text+    -> Schema+    -> Value+    -> [Failure]+validate rs = continueValidating rs (AN.VisitedSchemas [(Nothing, Nothing)])++-- A schema for schemas themselves, using @src/draft4.json@ which is loaded+-- at compile time.+schemaForSchemas :: Schema+schemaForSchemas =+      fromMaybe (error "Schema decode failed (this should never happen)")+    . decode+    . LBS.fromStrict+    $ schemaForSchemasBytes++checkSchema :: Schema -> [Failure]+checkSchema = validate referenced Nothing schemaForSchemas . Object . _unSchema+  where+    referenced :: ReferencedSchemas Schema+    referenced = ReferencedSchemas+                     schemaForSchemas+                     (HM.singleton "http://json-schema.org/draft-04/schema"+                         schemaForSchemas)++--------------------------------------------------+-- * Spec+--------------------------------------------------++continueValidating+    :: ReferencedSchemas Schema+    -> AN.VisitedSchemas+    -> Maybe Text+    -> Schema+    -> Value+    -> [Failure]+continueValidating referenced visited mURI sc =+    JT.validate (d4Spec referenced visited newScope) sc+  where+    schemaId :: Maybe Text+    schemaId = case HM.lookup "id" (_unSchema sc) of+                   Just (String t) -> Just t+                   _               -> Nothing++    newScope :: Maybe Text+    newScope = updateResolutionScope mURI schemaId++d4Spec+    :: ReferencedSchemas Schema+    -> AN.VisitedSchemas+    -> Maybe Text+    -> Spec Schema ValidatorChain+d4Spec referenced visited scope =+    Spec+        [ dimap f (const MultipleOf) D4.multipleOf+        , dimap f maxE D4.maximumVal+        , dimap f minE D4.minimumVal++        , dimap f (const MaxLength) D4.maxLength+        , dimap f (const MinLength) D4.minLength+        , dimap f (const PatternValidator) D4.patternVal++        , 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 (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 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 (const AnyOf) (D4.anyOf lateral)+        , dimap f (const OneOf) (D4.oneOf lateral)+        , dimap f (const NotValidator) (D4.notVal lateral)+        ]+  where+    f :: FromJSON a => Schema -> Maybe a+    f (Schema a) = case AE.fromJSON (Object a) of+                       AE.Error _   -> Nothing+                       AE.Success b -> Just b++    -- 'Maybe Text' is the URI the refernced schema is fetch from,+    -- this probably needs a 'newtype' wrapper.+    refVal :: AN.VisitedSchemas -> Maybe Text -> Schema -> Value -> [Failure]+    refVal = continueValidating referenced++    descend :: Schema -> Value -> [Failure]+    descend = continueValidating referenced mempty scope++    lateral :: Schema -> Value -> [Failure]+    lateral = continueValidating referenced visited scope

@@ -1,71 +0,0 @@--- | A custom schema specification using one validator from--- 'Data.Validator.Draft4' and one original validator.------ This is a simple example because it doesn't allow references (so it--- doesn't need to define an 'embed' function @Schema -> [Schema]@ for use--- with 'fetchReferencedSchemas'.------ For a full example see 'Data.JsonSchema.Draft4' and its submodules.--- Code use between schema specifications will likely be OK but not great.--- All the 'Data.Validator' code as well as the 'Data.JsonSchema.Fetch' code--- is reusable, but there's a lot of boilerplate to tie it together.--module CustomSchema where--import           Control.Applicative-import           Data.Aeson-import           Data.Maybe             (maybeToList)-import           Data.Monoid-import           Data.Text              (Text)-import qualified Data.Text              as T--import qualified Data.Validator.Draft4  as VA-import qualified Data.Validator.Failure as FR---- | Our custom validator.-oddLength :: Bool -> Text -> Maybe (FR.Failure () )-oddLength b t-  | b == odd (T.length t) = Nothing-  | otherwise             = Just (FR.Invalid () (Bool b) mempty)--data CustomError-  = MaxLength-  | OddLength---- If we were really using the schema we would also need ToJSON and FromJSON--- instances.-data Schema = Schema-  { _schemaMaxLength :: Maybe Int-  , _schemaOddLength :: Maybe Bool-  }---- | If our 'Schema's themselves could be invalid we might want to write--- something like 'Data.JsonSchema.Draft4.schemaValidityy' for them.-validate :: Schema -> Value -> [FR.Failure CustomError]-validate s (String x) = concat-  [ f _schemaMaxLength (FR.setFailure MaxLength) (fmap maybeToList . VA.maxLength)-  , f _schemaOddLength (FR.setFailure OddLength) (fmap maybeToList . oddLength)-  ]-  where-    -- This pattern is overkill here, but is helpful if you have lots of-    -- validators (e.g. the Draft 4 schema has 27).-    f :: (Schema -> Maybe val)-      -> (err -> FR.Failure CustomError)-      -> (val -> Text -> [err])-      -> [FR.Failure CustomError]-    f field modifyError runVal =-      maybe mempty (\val -> modifyError <$> runVal val x) (field s)-validate _ _ = mempty -- Our schema passes everything that isn't a string.--example :: IO ()-example =-  case validate schema badData of-    [] -> error "We validated bad data."-    [FR.Invalid OddLength _ _] -> return () -- Success.-    _ -> error "We got a different failure than expected."-  where-    schema :: Schema-    schema = Schema (Just 100) (Just True)--    badData :: Value-    badData = String "even"

@@ -1,9 +1,15 @@--- | Step by step validation using 'D4.referencesViaFilesystem' and--- 'D4.checkSchema'. This means the actual validation invovles no IO.+-- | 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+import           Data.Aeson             (Value (..), toJSON)  import qualified Data.JsonSchema.Draft4 as D4 @@ -12,23 +18,23 @@  schemaContext :: D4.SchemaWithURI D4.Schema schemaContext = D4.SchemaWithURI-  { D4._swSchema = schema-  , D4._swURI    = Just "./examples/json/imaginary.json"-  }+    { 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-  case res of-    Left _      -> error "Couldn't fetch referenced schemas."-    Right references -> do-      let validate = case D4.checkSchema references schemaContext of+    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+    case validate badData of         [] -> error "We validated bad data."-        [D4.Invalid (D4.Ref D4.UniqueItems) _ _] -> return () -- Success.-        e -> error "We got a different failure than expected."+        [D4.Failure (D4.Ref D4.UniqueItems) _ _ _] -> return () -- Success+        _ -> error "We got a different failure than expected."

@@ -1,53 +0,0 @@--- | 'D4.Invalid's contain a JSON Pointer to the subset of the data that--- caused validation to fail, but they don't contain that data itself.------ If you want to display the invalid subset of the data here's how you--- resolve the JSON Pointer (which has the field name--- 'D4._invalidOffendingData') against the original data.------ NOTE: You have to have hjsonpointer in your build-depends.--module PrettyShowFailure where--import           Data.Aeson-import qualified Data.Aeson.Pointer     as AP-import           Data.Monoid--import qualified Data.JsonSchema.Draft4 as D4--badData :: Value-badData = toJSON [1, 2 :: Int]--failure :: D4.Invalid-failure = D4.Invalid-  { D4._invalidValidatorsCalled = D4.Items D4.MultipleOf-  , D4._invalidFinalValidator   = Number 2-  , D4._invalidOffendingData    = AP.Pointer [AP.Token "0"]-  }--example :: IO ()-example =-  case AP.resolve (D4._invalidOffendingData failure) badData of-    Left _  -> error "Couldn't resolve pointer."-    Right _ -> return () -- Success. We could feed the 'Right' value into-                         -- the otherwise unused 'msg' if we wanted to-                         -- display it.--msg :: Value -> String-msg subsetOfData = unlines-  [ "Invalid data. Here's the sequence of validators that caught it:"-  , ""-  , "  " <> show (D4._invalidValidatorsCalled failure)-  , ""-  , "Here's the contents of the final validator in that sequence:"-  , ""-  , "  " <> show (D4._invalidFinalValidator failure)-  , ""-  , "Here's a JSON Pointer to the invalid part of the data:"-  , ""-  , "  " <> show (D4._invalidOffendingData failure)-  , ""-  , "Here's the invalid part of the data:"-  , ""-  , "  " <> show subsetOfData-  ]

@@ -1,39 +1,37 @@--- | Fetch any referenced schemas, check that our original schema is itself--- valid, then validate our data.+-- | Demonstrate 'D4.fetchFilesystemAndValidate'. -- -- To fetch schemas using HTTP instead of from the filesystem use -- 'D4.fetchHTTPAndValidate'.  module Simple where -import           Data.Aeson-import qualified Data.List.NonEmpty as NE+import           Data.Aeson             (Value(..), decode, toJSON)+import qualified Data.ByteString.Lazy   as LBS+import qualified Data.List.NonEmpty     as NE+import           Data.Maybe             (fromMaybe)  import 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/imaginary.json"-  -- ^ For this example we're pretending we found 'schema' at this location.-  -- Its relative links will be resolved from here.-  }- badData :: Value badData = toJSON (["foo", "foo"] :: [String])  example :: IO () example = do-  res <- D4.fetchFilesystemAndValidate schemaContext 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) ->-      case NE.toList failures of-        [D4.Invalid (D4.Ref D4.UniqueItems) _ _] -> return () -- Success.-        _ -> error "Got more invalidation reasons than we expected."++    -- 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")++    -- Fetch any referenced schemas, check that our original schema itself+    -- is valid, and validate the data.+    res <- D4.fetchFilesystemAndValidate 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) ->+            case NE.toList failures of+                [D4.Failure (D4.Ref D4.UniqueItems) _ _ _] -> return () -- Success.+                _ -> error "Got more invalidation reasons than we expected."

@@ -0,0 +1,3 @@+{+  "$ref": "./unique.json"+}

@@ -1,5 +1,5 @@ name:                   hjsonschema-version:                0.10.0.3+version:                1.0.0.0 synopsis:               JSON Schema library homepage:               https://github.com/seagreen/hjsonschema license:                MIT@@ -14,33 +14,43 @@                         JSON-Schema-Test-Suite/remotes/*.json                         JSON-Schema-Test-Suite/remotes/folder/*.json                         JSON-Schema-Test-Suite/tests/draft4/*.json+                        JSON-Schema-Test-Suite/tests/draft4/optional/*.json                         README.md                         src/draft4.json                         test/Local/*.json+                        test/supplement/*.json                         examples/json/*.json  library   hs-source-dirs:       src   exposed-modules:      Data.JsonSchema.Draft4-                      , Data.JsonSchema.Draft4.Internal+                      , Data.JsonSchema.Draft4.Failure+                      , Data.JsonSchema.Draft4.Schema+                      , Data.JsonSchema.Draft4.Spec                       , Data.JsonSchema.Fetch+                      , Data.JsonSchema.Types                       , Data.Validator.Draft4-                      , Data.Validator.Failure-                      , Data.Validator.Reference-                      , Data.Validator.Utils--  other-modules:        Data.JsonSchema.Draft4.Failure-                      , Data.JsonSchema.Draft4.Schema                       , Data.Validator.Draft4.Any                       , Data.Validator.Draft4.Array                       , Data.Validator.Draft4.Number                       , Data.Validator.Draft4.Object-                      , Data.Validator.Draft4.Object.Properties                       , Data.Validator.Draft4.String+                      , Data.Validator.Failure+                      , Data.Validator.Reference+                      , Data.Validator.Types+                      , Data.Validator.Utils++  other-modules:        Data.Validator.Draft4.Object.Properties                       , Import   default-language:     Haskell2010-  default-extensions:   ScopedTypeVariables+  default-extensions:   NoImplicitPrelude                         OverloadedStrings+                        ScopedTypeVariables+  if impl(ghc >= 8)+    default-extensions: StrictData+  other-extensions:     DeriveFunctor+                        GeneralizedNewtypeDeriving+                        TemplateHaskell   ghc-options:          -Wall   build-depends:        aeson                >= 0.7    && < 0.12                       , base                 >= 4.7    && < 4.10@@ -49,10 +59,12 @@                       , file-embed           >= 0.0.8  && < 0.1                       , filepath             >= 1.3    && < 1.5                       , hjsonpointer         >= 0.3    && < 0.4-                      , http-client          >= 0.4    && < 0.6+                      -- 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-                      , QuickCheck           >= 2.8.1  && < 2.9+                      , profunctors          >= 5.0    && < 5.3+                      , QuickCheck           >= 2.8    && < 2.10                       , scientific           >= 0.3    && < 0.4                       , semigroups           >= 0.18   && < 0.19                       , unordered-containers >= 0.2    && < 0.3@@ -65,49 +77,61 @@                         examples   main-is:              Local.hs   other-modules:        Local.Failure-                      , Local.Filesystem                       , Local.Reference+                      , Local.Validation                       , Shared                       -- from ./examples:-                      , CustomSchema+                      , AlternateSchema                       , Full-                      , PrettyShowFailure                       , Simple   default-language:     Haskell2010-  ghc-options:          -Wall -fno-warn-orphans+  ghc-options:          -Wall+                        -fno-warn-orphans   default-extensions:   OverloadedStrings+                        ScopedTypeVariables   build-depends:        aeson                       , base                       , bytestring                       , filepath                       , hjsonpointer                       , hjsonschema+                      , profunctors                       , semigroups                       , text                       , QuickCheck                       , unordered-containers                       , vector-                      , directory            >= 1.2  && < 1.3-                      , HUnit                >= 1.2  && < 1.4-                      , tasty                >= 0.11 && < 0.12-                      , tasty-hunit          >= 0.9  && < 0.10-                      , tasty-quickcheck     >= 0.8  && < 0.9+                      -- directory-1.2.5 required for `listDirectory`:+                      , directory            >= 1.2.5 && < 1.3+                      , HUnit                >= 1.2   && < 1.4+                      , tasty                >= 0.11  && < 0.12+                      , tasty-hunit          >= 0.9   && < 0.10+                      , tasty-quickcheck     >= 0.8   && < 0.9  test-suite remote   type:                 exitcode-stdio-1.0   hs-source-dirs:       test+                        examples   main-is:              Remote.hs   other-modules:        Shared+                      -- from ./examples:+                      , AlternateSchema   default-language:     Haskell2010-  ghc-options:          -Wall -fno-warn-orphans+  ghc-options:          -Wall+                        -fno-warn-orphans   default-extensions:   OverloadedStrings+                        ScopedTypeVariables   build-depends:        aeson                       , async                       , base                       , bytestring                       , filepath+                      , hjsonpointer                       , hjsonschema+                      , profunctors+                      , semigroups                       , text+                      , unordered-containers                       , vector                       , directory                       , HUnit

@@ -1,136 +1,185 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TemplateHaskell #-}  module Data.JsonSchema.Draft4-  ( Schema(..)-  , emptySchema+    ( -- * Draft 4 Schema+      SchemaWithURI(..)+    , Schema(..)+    , SC.emptySchema -    -- * One-step validation-  , HTTPValidationFailure(..)-  , fetchHTTPAndValidate-  , FilesystemValidationFailure(..)-  , fetchFilesystemAndValidate+      -- * One-step validation (getting references over HTTP)+    , fetchHTTPAndValidate+    , HTTPValidationFailure(..)+    , FE.HTTPFailure(..)+    , InvalidSchema -    -- * Fetching tools-  , SchemaWithURI(..)-  , ReferencedSchemas(..)-  , HTTPFailure(..)-  , referencesViaHTTP-  , FilesystemFailure(..)-  , referencesViaFilesystem+      -- * One-step validation (getting references from the filesystem)+    , fetchFilesystemAndValidate+    , FilesystemValidationFailure(..)+    , FE.FilesystemFailure(..) -    -- * Failure-  , Invalid-  , FR.Failure(..)-  , ValidatorChain(..)+      -- * Validation failure+    , Invalid+    , Failure+    , FR.Fail(..)+    , ValidatorChain(..) -    -- * Other Draft 4 things exported just in case-  , checkSchema-  , schemaValidity-  , IN.runValidate-  , draft4Spec-  ) where+      -- * Fetching tools+    , ReferencedSchemas(..)+    , referencesViaHTTP+    , referencesViaFilesystem -import           Control.Applicative-import           Control.Arrow                   (left)-import           Data.Aeson+      -- * Other Draft 4 things exported just in case+    , schemaForSchemas+    , schemaForSchemasBytes+    , schemaValidity+    , referencesValidity+    , checkSchema+    , draft4FetchInfo+    ) where++import           Import+import           Prelude++import           Control.Arrow                   (first, left)+import qualified Data.ByteString                 as BS import qualified Data.ByteString.Lazy            as LBS-import           Data.FileEmbed-import qualified Data.HashMap.Strict             as H-import           Data.List.NonEmpty              (NonEmpty)-import qualified Data.List.NonEmpty              as N+import           Data.FileEmbed                  (embedFile,+                                                  makeRelativeToProject)+import qualified Data.HashMap.Strict             as HM+import qualified Data.List.NonEmpty              as NE import           Data.Maybe                      (fromMaybe) -import           Data.JsonSchema.Draft4.Failure  (Invalid, ValidatorChain(..))-import qualified Data.JsonSchema.Draft4.Internal as IN-import           Data.JsonSchema.Draft4.Schema-import           Data.JsonSchema.Fetch           (FilesystemFailure(..),-                                                  HTTPFailure(..),-                                                  ReferencedSchemas(..),+import           Data.JsonSchema.Draft4.Failure  (Failure, Invalid,+                                                  InvalidSchema,+                                                  ValidatorChain(..))+import           Data.JsonSchema.Draft4.Schema   (Schema)+import qualified Data.JsonSchema.Draft4.Schema   as SC+import qualified Data.JsonSchema.Draft4.Spec     as Spec+import           Data.JsonSchema.Fetch           (ReferencedSchemas(..),                                                   SchemaWithURI(..)) import qualified Data.JsonSchema.Fetch           as FE import qualified Data.Validator.Failure          as FR  data HTTPValidationFailure-  = HVRequest HTTPFailure-  | HVSchema  (NonEmpty Invalid)-  | HVData    (NonEmpty Invalid)-  deriving Show+    = HVRequest FE.HTTPFailure+    | HVSchema  InvalidSchema+    | HVData    Invalid+    deriving Show +-- | Fetch recursively referenced schemas over HTTP, check that both the+-- original and referenced schemas are valid, and then validate data. fetchHTTPAndValidate-  :: SchemaWithURI Schema-  -> Value-  -> IO (Either HTTPValidationFailure ())+    :: SchemaWithURI Schema+    -> Value+    -> IO (Either HTTPValidationFailure ()) fetchHTTPAndValidate sw v = do-  res <- referencesViaHTTP sw-  pure (g =<< f =<< left HVRequest res)+    res <- referencesViaHTTP sw+    pure (g =<< f =<< left HVRequest res)   where-    f :: ReferencedSchemas Schema-      -> Either HTTPValidationFailure (Value -> [Invalid])+    f :: FE.URISchemaMap Schema+      -> Either HTTPValidationFailure (Value -> [Failure])     f references = left HVSchema (checkSchema references sw) -    g :: (Value -> [Invalid]) -> Either HTTPValidationFailure ()-    g validate = case N.nonEmpty (validate v) of-                   Nothing       -> Right ()-                   Just failures -> Left (HVData failures)+    g :: (Value -> [Failure]) -> Either HTTPValidationFailure ()+    g validate = case NE.nonEmpty (validate v) of+                     Nothing       -> Right ()+                     Just failures -> Left (HVData failures)  data FilesystemValidationFailure-  = FVRead   FilesystemFailure-  | FVSchema (NonEmpty Invalid)-  | FVData   (NonEmpty Invalid)-  deriving Show+    = FVRead   FE.FilesystemFailure+    | FVSchema InvalidSchema+    | FVData   Invalid+    deriving (Show, Eq) +-- | Fetch recursively referenced schemas from the filesystem, check that+-- both the original and referenced schemas are valid, and then+-- validate data. fetchFilesystemAndValidate-  :: SchemaWithURI Schema-  -> Value-  -> IO (Either FilesystemValidationFailure ())+    :: SchemaWithURI Schema+    -> Value+    -> IO (Either FilesystemValidationFailure ()) fetchFilesystemAndValidate sw v = do-  res <- referencesViaFilesystem sw-  pure (g =<< f =<< left FVRead res)+    res <- referencesViaFilesystem sw+    pure (g =<< f =<< left FVRead res)   where-    f :: ReferencedSchemas Schema-      -> Either FilesystemValidationFailure (Value -> [Invalid])+    f :: FE.URISchemaMap Schema+      -> Either FilesystemValidationFailure (Value -> [Failure])     f references = left FVSchema (checkSchema references sw) -    g :: (Value -> [Invalid]) -> Either FilesystemValidationFailure ()-    g validate = case N.nonEmpty (validate v) of-                   Nothing       -> Right ()-                   Just failures -> Left (FVData failures)---- | Check the that a schema itself is valid.------ Return a function to validate data.-checkSchema-  :: ReferencedSchemas Schema-  -> SchemaWithURI Schema-  -> Either (NonEmpty Invalid) (Value -> [Invalid])-checkSchema referenced schemaWithURI =-  case N.nonEmpty . schemaValidity . _swSchema $ schemaWithURI of-    Nothing       -> Right (IN.runValidate referenced schemaWithURI)-    Just failures -> Left failures+    g :: (Value -> [Failure]) -> Either FilesystemValidationFailure ()+    g validate = case NE.nonEmpty (validate v) of+                     Nothing      -> Right ()+                     Just invalid -> Left (FVData invalid) -draft4Spec :: FE.Spec Schema-draft4Spec = FE.Spec IN.embedded _schemaId _schemaRef+-- | An instance of 'Data.JsonSchema.Fetch.FetchInfo' specialized for+-- JSON Schema Draft 4.+draft4FetchInfo :: FE.FetchInfo Schema+draft4FetchInfo = FE.FetchInfo Spec.embedded SC._schemaId SC._schemaRef +-- | Fetch the schemas recursively referenced by a starting schema over HTTP. referencesViaHTTP-  :: SchemaWithURI Schema-  -> IO (Either HTTPFailure (ReferencedSchemas Schema))-referencesViaHTTP = FE.referencesViaHTTP' draft4Spec+    :: SchemaWithURI Schema+    -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema))+referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo +-- | Fetch the schemas recursively referenced by a starting schema from+-- the filesystem. referencesViaFilesystem-  :: SchemaWithURI Schema-  -> IO (Either FilesystemFailure (ReferencedSchemas Schema))-referencesViaFilesystem = FE.referencesViaFilesystem' draft4Spec+    :: SchemaWithURI Schema+    -> IO (Either FE.FilesystemFailure (FE.URISchemaMap Schema))+referencesViaFilesystem = FE.referencesViaFilesystem' draft4FetchInfo --- | Check that a schema itself is valid.-schemaValidity :: Schema -> [Invalid]-schemaValidity = IN.runValidate referenced (SchemaWithURI d4 Nothing) . toJSON+-- | A helper function.+--+-- Checks if a schema and a set of referenced schemas are valid.+--+-- Return a function to validate data.+checkSchema+    :: FE.URISchemaMap Schema+    -> SchemaWithURI Schema+    -> Either InvalidSchema (Value -> [Failure])+checkSchema sm sw =+    case NE.nonEmpty failures of+        Nothing -> Right (Spec.validate (ReferencedSchemas (_swSchema sw) sm) sw)+        Just fs -> Left fs   where-    d4 :: Schema-    d4 = fromMaybe (error "Schema decode failed (this should never happen)")-       . decode . LBS.fromStrict $ $(embedFile "src/draft4.json")+    failures :: [(Maybe Text, Failure)]+    failures = ((\v -> (Nothing, v)) <$> schemaValidity (_swSchema sw))+            <> (first Just <$> referencesValidity sm) +schemaForSchemas :: Schema+schemaForSchemas =+      fromMaybe (error "Schema decode failed (this should never happen)")+    . decode+    . LBS.fromStrict+    $ schemaForSchemasBytes++schemaForSchemasBytes :: BS.ByteString+schemaForSchemasBytes =+    $(makeRelativeToProject "src/draft4.json" >>= embedFile)++-- | Check that a schema itself is valid+-- (if so the returned list will be empty).+schemaValidity :: Schema -> [Failure]+schemaValidity =+    Spec.validate referenced (SchemaWithURI schemaForSchemas Nothing) . toJSON+  where     referenced :: ReferencedSchemas Schema     referenced = ReferencedSchemas-                   d4-                   (H.singleton "http://json-schema.org/draft-04/schema" d4)+                     schemaForSchemas+                     (HM.singleton "http://json-schema.org/draft-04/schema"+                         schemaForSchemas)++-- | Check that a set of referenced schemas are valid+-- (if so the returned list will be empty).+referencesValidity+  :: FE.URISchemaMap Schema+  -> [(Text, Failure)]+  -- ^ The first value in the tuple is the URI of a referenced schema.+referencesValidity = HM.foldlWithKey' f mempty+  where+    f :: [(Text, Failure)]+      -> Text+      -> Schema+      -> [(Text, Failure)]+    f acc k v = ((\a -> (k,a)) <$> schemaValidity v) <> acc

@@ -1,53 +1,118 @@  module Data.JsonSchema.Draft4.Failure where -import qualified Data.Validator.Failure as FR+import           Prelude -type Invalid = FR.Failure ValidatorChain+import           Data.List.NonEmpty            (NonEmpty)+import           Data.Text                     (Text) +import qualified Data.Validator.Draft4.Any    as AN+import qualified Data.Validator.Draft4.Array  as AR+import qualified Data.Validator.Draft4.Number as NU+import qualified Data.Validator.Draft4.Object as OB+import qualified Data.Validator.Failure       as FR++-- | A description of why a schema (or one of its reference) is itself+-- invalid.+--+-- 'Nothing' indicates the starting schema. 'Just' indicates a referenced+-- schema -- the contents of the 'Just' is the schema's URI.+--+-- NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of defining+-- this, but then we lose the guarantee that there's at least one key.+type InvalidSchema = NonEmpty (Maybe Text, Failure)++type Invalid = NonEmpty Failure++type Failure = FR.Fail ValidatorChain++-- | Distinguish all the different possible causes of failure for+-- Draft 4 validation. data ValidatorChain-  = MultipleOf-  | Maximum-  | ExclusiveMaximum-  | Minimum-  | ExclusiveMinimum+    = MultipleOf+    | Maximum+    | ExclusiveMaximum+    | Minimum+    | ExclusiveMinimum -  | MaxLength-  | MinLength-  | PatternValidator+    | MaxLength+    | MinLength+    | PatternValidator -  | MaxItems-  | MinItems-  | UniqueItems-  | Items ValidatorChain-  | AdditionalItemsBool-  | AdditionalItemsObject ValidatorChain+    | MaxItems+    | MinItems+    | UniqueItems+    | Items ValidatorChain+    | AdditionalItemsBool+    | AdditionalItemsObject ValidatorChain -  | MaxProperties-  | MinProperties-  | Required-  | SchemaDependency ValidatorChain-  | PropertyDependency-  | Properties ValidatorChain-  | PatternProperties ValidatorChain-  | AdditionalPropertiesBool-  | AdditionalPropertiesObject ValidatorChain+    | MaxProperties+    | MinProperties+    | Required+    | SchemaDependency ValidatorChain+    | PropertyDependency+    | Properties ValidatorChain+    | PatternProperties ValidatorChain+    | AdditionalPropertiesBool+    | AdditionalPropertiesObject ValidatorChain -  | RefResolution-    -- ^ Indicates a reference that failed to resolve.-    ---    -- NOTE: The language agnostic test suite doesn't specify if this should-    -- cause a validation error or should allow data to pass. We choose to-    -- return a validation error.-    ---    -- Also note that ideally we would enforce in the type system that any-    -- failing references be dealt with before valididation. Then this could-    -- be removed entirely.-  | Ref ValidatorChain-  | Enum-  | TypeValidator-  | AllOf ValidatorChain-  | AnyOf-  | OneOf-  | NotValidator-  deriving (Eq, Show)+    | 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+    | OneOf+    | NotValidator+    deriving (Eq, Show)++maxE :: NU.MaximumInvalid -> ValidatorChain+maxE NU.Maximum          = Maximum+maxE NU.ExclusiveMaximum = ExclusiveMaximum++minE :: NU.MinimumInvalid -> ValidatorChain+minE NU.Minimum          = Minimum+minE NU.ExclusiveMinimum = ExclusiveMinimum++itemsE :: AR.ItemsInvalid ValidatorChain -> ValidatorChain+itemsE (AR.Items err)                        = Items err+itemsE AR.AdditionalItemsBoolInvalid         = AdditionalItemsBool+itemsE (AR.AdditionalItemsObjectInvalid err) = AdditionalItemsObject err++depsE :: OB.DependencyInvalid ValidatorChain -> ValidatorChain+depsE (OB.SchemaDependencyInvalid err) = SchemaDependency err+depsE OB.PropertyDependencyInvalid     = PropertyDependency++propE :: OB.PropertiesInvalid ValidatorChain -> ValidatorChain+propE (OB.PropertiesInvalid err)   = Properties err+propE (OB.PropPatternInvalid err)  = PatternProperties err+propE (OB.PropAdditionalInvalid a) =+    case a of+        OB.APBoolInvalid       -> AdditionalPropertiesBool+        OB.APObjectInvalid err -> AdditionalPropertiesObject err++patPropE :: OB.PatternPropertiesInvalid ValidatorChain -> ValidatorChain+patPropE (OB.PPInvalid err) = PatternProperties err+patPropE (OB.PPAdditionalPropertiesInvalid a)   =+    case a of+        OB.APBoolInvalid       -> AdditionalPropertiesBool+        OB.APObjectInvalid err -> AdditionalPropertiesObject err++addPropE :: OB.AdditionalPropertiesInvalid ValidatorChain -> ValidatorChain+addPropE OB.APBoolInvalid         = AdditionalPropertiesBool+addPropE (OB.APObjectInvalid err) = AdditionalItemsObject err++refE :: AN.RefInvalid ValidatorChain -> ValidatorChain+refE AN.RefResolution    = RefResolution+refE AN.RefLoop          = RefLoop+refE (AN.RefInvalid err) = Ref err

@@ -1,267 +0,0 @@--module Data.JsonSchema.Draft4.Internal where--import           Data.Aeson-import qualified Data.HashMap.Strict            as H-import qualified Data.List.NonEmpty             as N-import           Data.Maybe                     (catMaybes, fromMaybe, isJust,-                                                 maybeToList)-import           Data.Scientific--import           Data.JsonSchema.Draft4.Failure-import           Data.JsonSchema.Draft4.Schema-import           Data.JsonSchema.Fetch          (ReferencedSchemas(..),-                                                 SchemaWithURI(..))-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         (modFailure, setFailure)-import qualified Data.Validator.Failure         as FR-import           Data.Validator.Reference       (updateResolutionScope)-import           Import---- For GHCs before 7.10:-import           Prelude                        hiding (concat)------------------------------------------------------- * Embedded Schemas------------------------------------------------------- | Return a schema's immediate subschemas.------ Pass this to 'fetchReferencedSchemas' so that function can find all the--- subschemas in a document. This allows 'fetchReferencedSchemas' to process--- only "$ref"s and "id"s that are actual schema keywords. For example,--- within a "properties" validator object an "id" key doesn't actually change--- any scope, but instead serves a validator-specific function.-embedded :: Schema -> [Schema]-embedded schema = concat-  [ f _schemaItems-      (\x -> case x of-               AR.ItemsObject s -> pure s-               AR.ItemsArray ss -> ss-      )-  , f _schemaAdditionalItems-      (\x -> case x of-               AR.AdditionalObject s -> pure s-               _                     -> mempty-      )-  , f _schemaDependencies (catMaybes . fmap checkDependency . H.elems)-  , f _schemaProperties H.elems-  , f _schemaPatternProperties H.elems-  , f _schemaAdditionalProperties-      (\x -> case x of-               OB.AdditionalPropertiesObject s -> pure s-               _                               -> mempty-      )-  , f _schemaAllOf N.toList-  , f _schemaAnyOf N.toList-  , f _schemaOneOf N.toList-  , f _schemaNot pure-  , f _schemaDefinitions H.elems-  ]-  where-    f :: (Schema -> Maybe a) -> (a -> [Schema]) -> [Schema]-    f field nextLevelEmbedded = maybe mempty nextLevelEmbedded (field schema)--    checkDependency :: OB.Dependency Schema -> Maybe Schema-    checkDependency (OB.PropertyDependency _) = Nothing-    checkDependency (OB.SchemaDependency s)   = Just s------------------------------------------------------- * Validation (Main internal functions)-----------------------------------------------------runValidate-  :: ReferencedSchemas Schema-  -> SchemaWithURI Schema-  -> Value-  -> [Invalid]-runValidate referenced sw x = concat-  [ f _schemaEnum  (setFailure Enum)          (fmap maybeToList . AN.enumVal)-  , f _schemaType  (setFailure TypeValidator) (fmap maybeToList . AN.typeVal)-  , f _schemaAllOf (modFailure AllOf)         (AN.allOf recurse)-  , f _schemaAnyOf (setFailure AnyOf)         (fmap maybeToList . AN.anyOf recurse)-  , f _schemaOneOf (setFailure OneOf)         (fmap maybeToList . AN.oneOf recurse)-  , f _schemaNot   (setFailure NotValidator)  (fmap maybeToList . AN.notVal recurse)-  , refFailures-  ] <> specificValidators-  where-    specificValidators :: [Invalid]-    specificValidators =-      case x of-        Number y -> validateNumber (_swSchema sw) y-        String y -> validateString (_swSchema sw) y-        Array y  -> validateArray referenced sw y-        Object y -> validateObject referenced sw y-        _        -> mempty--    f = runSingle (_swSchema sw) x--    recurse = descendNextLevel referenced sw--    -- Since the results of the 'AN.ref' validator are fairly complicated [1]-    -- it's simpler not to use our 'f' helper function for it.-    ---    -- [1] A list of errors wrapped in a 'Maybe' where 'Nothing' represents-    -- if resolving the reference itself failed.-    refFailures :: [Invalid]-    refFailures =-      case _schemaRef (_swSchema sw) of-        Nothing        -> mempty-        Just reference ->-          maybe [FR.Invalid RefResolution (toJSON reference) mempty]-                (fmap (modFailure Ref))-                $ AN.ref scope-                         getReference-                         (\a b -> runValidate referenced (SchemaWithURI b a))-                         reference-                         x-      where-        scope :: Maybe Text-        scope = updateResolutionScope (_swURI sw) (_schemaId (_swSchema sw))--        getReference :: Maybe Text -> Maybe Schema-        getReference Nothing  = Just (_rsStarting referenced)-        getReference (Just t) = H.lookup t (_rsSchemaMap referenced)--validateString-  :: Schema-  -> Text-  -> [Invalid]-validateString schema x = concat-  [ f _schemaMaxLength (setFailure MaxLength)        (fmap maybeToList . ST.maxLength)-  , f _schemaMinLength (setFailure MinLength)        (fmap maybeToList . ST.minLength)-  , f _schemaPattern   (setFailure PatternValidator) (fmap maybeToList . ST.patternVal)-  ]-  where-    f = runSingle schema x--validateNumber-  :: Schema-  -> Scientific-  -> [Invalid]-validateNumber schema x = concat-  [ f _schemaMultipleOf (setFailure MultipleOf) (fmap maybeToList . NU.multipleOf)-  , f _schemaMaximum-      (modFailure fMax)-      ( fmap maybeToList-      . NU.maximumVal (fromMaybe False (_schemaExclusiveMaximum schema))-      )-  , f _schemaMinimum-      (modFailure fMin)-      ( fmap maybeToList-      . NU.minimumVal (fromMaybe False (_schemaExclusiveMinimum schema))-      )-  ]-  where-    f = runSingle schema x--    fMax NU.Maximum          = Maximum-    fMax NU.ExclusiveMaximum = ExclusiveMaximum--    fMin NU.Minimum          = Minimum-    fMin NU.ExclusiveMinimum = ExclusiveMinimum--validateArray-  :: ReferencedSchemas Schema-  -> SchemaWithURI Schema-  -> Vector Value-  -> [Invalid]-validateArray referenced (SchemaWithURI schema mUri) x = concat-  [ f _schemaMaxItems    (setFailure MaxItems)    (fmap maybeToList . AR.maxItems)-  , f _schemaMinItems    (setFailure MinItems)    (fmap maybeToList . AR.minItems)-  , f _schemaUniqueItems (setFailure UniqueItems) (fmap maybeToList . AR.uniqueItems)-  , f _schemaItems-      (modFailure fItems)-      (AR.items recurse (_schemaAdditionalItems schema))-  ]-  where-    f = runSingle schema x--    recurse = descendNextLevel referenced (SchemaWithURI schema mUri)--    fItems (AR.Items err)                        = Items err-    fItems AR.AdditionalItemsBoolInvalid         = AdditionalItemsBool-    fItems (AR.AdditionalItemsObjectInvalid err) = AdditionalItemsObject err--validateObject-  :: ReferencedSchemas Schema-  -> SchemaWithURI Schema-  -> HashMap Text Value-  -> [Invalid]-validateObject referenced (SchemaWithURI schema mUri) x = concat-  [ f _schemaMaxProperties (setFailure MaxProperties) (fmap maybeToList . OB.maxProperties)-  , f _schemaMinProperties (setFailure MinProperties) (fmap maybeToList . OB.minProperties)-  , f _schemaRequired      (setFailure Required)      (fmap maybeToList . OB.required)-  , f _schemaDependencies  (modFailure fDeps)         (OB.dependencies recurse)--  , f _schemaProperties-      (modFailure fProp)-      (OB.properties recurse-                     (_schemaPatternProperties schema)-                     (_schemaAdditionalProperties schema))--  , f _schemaPatternProperties-      (modFailure fPatProp)-      (case _schemaProperties schema of-        Just _  -> const (const mempty)-        Nothing -> OB.patternProperties recurse (_schemaAdditionalProperties schema))--  , f _schemaAdditionalProperties-      (modFailure fAddProp)-      (if isJust (_schemaProperties schema) || isJust (_schemaPatternProperties schema)-        then const (const mempty)-        else OB.additionalProperties recurse)-  ]-  where-    f = runSingle schema x--    recurse = descendNextLevel referenced (SchemaWithURI schema mUri)--    fDeps (OB.SchemaDependencyInvalid err) = SchemaDependency err-    fDeps OB.PropertyDependencyInvalid     = PropertyDependency--    fProp (OB.PropertiesInvalid err)   = Properties err-    fProp (OB.PropPatternInvalid err)  = PatternProperties err-    fProp (OB.PropAdditionalInvalid a) =-      case a of-        OB.APBoolInvalid       -> AdditionalPropertiesBool-        OB.APObjectInvalid err -> AdditionalPropertiesObject err--    fPatProp (OB.PPInvalid err) = PatternProperties err-    fPatProp (OB.PPAdditionalPropertiesInvalid a)   =-      case a of-        OB.APBoolInvalid       -> AdditionalPropertiesBool-        OB.APObjectInvalid err -> AdditionalPropertiesObject err--    fAddProp OB.APBoolInvalid         = AdditionalPropertiesBool-    fAddProp (OB.APObjectInvalid err) = AdditionalItemsObject err------------------------------------------------------- * Validation (Internal utils)-----------------------------------------------------descendNextLevel-  :: ReferencedSchemas Schema-  -> SchemaWithURI Schema-  -> Schema-  -> Value-  -> [Invalid]-descendNextLevel referenced (SchemaWithURI schema mUri) =-  runValidate referenced . flip SchemaWithURI scope-  where-    scope :: Maybe Text-    scope = updateResolutionScope mUri (_schemaId schema)--runSingle-  :: Schema-  -> dta-  -> (Schema -> Maybe val)-  -> (err -> Invalid)-  -> (val -> dta -> [err])-  -> [Invalid]-runSingle schema dta field modifyError validate =-  maybe mempty (\val -> modifyError <$> validate val dta) (field schema)

@@ -1,7 +1,10 @@  module Data.JsonSchema.Draft4.Schema where -import qualified Data.HashMap.Strict          as H+import           Import+import           Prelude++import qualified Data.HashMap.Strict          as HM import           Data.List.NonEmpty           (NonEmpty) import           Data.Maybe                   (fromJust, isJust) import           Data.Scientific@@ -10,325 +13,326 @@ import qualified Data.Validator.Draft4.Array  as AR import qualified Data.Validator.Draft4.Object as OB import           Data.Validator.Utils-import           Import  data Schema = Schema-  { _schemaVersion              :: Maybe Text-  , _schemaId                   :: Maybe Text-  , _schemaRef                  :: Maybe Text-  , _schemaDefinitions          :: Maybe (HashMap Text Schema)-  -- ^ A standardized location for embedding schemas-  -- to be referenced from elsewhere in the document.-  , _schemaOther                :: HashMap Text Value-  -- ^ Since the JSON document this Schema was built from could-  -- contain schemas anywhere (not just in "definitions" or any-  -- of the other official keys) we save any leftover key/value-  -- pairs not covered by them here.+    { _schemaVersion              :: Maybe Text+    , _schemaId                   :: Maybe Text+    , _schemaRef                  :: Maybe Text+    , _schemaDefinitions          :: Maybe (HashMap Text Schema)+    -- ^ A standardized location for embedding schemas+    -- to be referenced from elsewhere in the document.+    , _schemaOther                :: HashMap Text Value+    -- ^ Since the JSON document this schema was built from could+    -- contain schemas anywhere (not just in "definitions" or any+    -- of the other official keys) we save any leftover key/value+    -- pairs not covered by them here. -  , _schemaMultipleOf           :: Maybe Scientific-  , _schemaMaximum              :: Maybe Scientific-  , _schemaExclusiveMaximum     :: Maybe Bool-  , _schemaMinimum              :: Maybe Scientific-  , _schemaExclusiveMinimum     :: Maybe Bool+    , _schemaMultipleOf           :: Maybe Scientific+    , _schemaMaximum              :: Maybe Scientific+    , _schemaExclusiveMaximum     :: Maybe Bool+    , _schemaMinimum              :: Maybe Scientific+    , _schemaExclusiveMinimum     :: Maybe Bool -  , _schemaMaxLength            :: Maybe Int-  , _schemaMinLength            :: Maybe Int-  , _schemaPattern              :: Maybe Text+    , _schemaMaxLength            :: Maybe Int+    , _schemaMinLength            :: Maybe Int+    , _schemaPattern              :: Maybe Text -  , _schemaMaxItems             :: Maybe Int-  , _schemaMinItems             :: Maybe Int-  , _schemaUniqueItems          :: Maybe Bool-  , _schemaItems                :: Maybe (AR.Items Schema)-  -- Note that '_schemaAdditionalItems' is left out of 'runValidate'-  -- because its functionality is handled by '_schemaItems'. It always-  -- validates data unless 'Items' is present.-  , _schemaAdditionalItems      :: Maybe (AR.AdditionalItems Schema)+    , _schemaMaxItems             :: Maybe Int+    , _schemaMinItems             :: Maybe Int+    , _schemaUniqueItems          :: Maybe Bool+    , _schemaItems                :: Maybe (AR.Items Schema)+    -- Note that '_schemaAdditionalItems' is left out of 'runValidate'+    -- because its functionality is handled by '_schemaItems'. It always+    -- validates data unless 'Items' is present.+    , _schemaAdditionalItems      :: Maybe (AR.AdditionalItems Schema) -  , _schemaMaxProperties        :: Maybe Int-  , _schemaMinProperties        :: Maybe Int-  , _schemaRequired             :: Maybe OB.Required-  , _schemaDependencies         :: Maybe (HashMap Text (OB.Dependency Schema))-  , _schemaProperties           :: Maybe (HashMap Text Schema)-  , _schemaPatternProperties    :: Maybe (HashMap Text Schema)-  , _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema)+    , _schemaMaxProperties        :: Maybe Int+    , _schemaMinProperties        :: Maybe Int+    , _schemaRequired             :: Maybe OB.Required+    , _schemaDependencies         :: Maybe (HashMap Text (OB.Dependency Schema))+    , _schemaProperties           :: Maybe (HashMap Text Schema)+    , _schemaPatternProperties    :: Maybe (HashMap Text Schema)+    , _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema) -  , _schemaEnum                 :: Maybe AN.EnumVal-  , _schemaType                 :: Maybe AN.TypeVal-  , _schemaAllOf                :: Maybe (NonEmpty Schema)-  , _schemaAnyOf                :: Maybe (NonEmpty Schema)-  , _schemaOneOf                :: Maybe (NonEmpty Schema)-  , _schemaNot                  :: Maybe Schema-  } deriving (Eq, Show)+    , _schemaEnum                 :: Maybe AN.EnumVal+    , _schemaType                 :: Maybe AN.TypeVal+    , _schemaAllOf                :: Maybe (NonEmpty Schema)+    , _schemaAnyOf                :: Maybe (NonEmpty Schema)+    , _schemaOneOf                :: Maybe (NonEmpty Schema)+    , _schemaNot                  :: Maybe Schema+    } deriving (Eq, Show)  emptySchema :: Schema emptySchema = Schema-  { _schemaVersion              = Nothing-  , _schemaId                   = Nothing-  , _schemaRef                  = Nothing-  , _schemaDefinitions          = Nothing-  , _schemaOther                = mempty+    { _schemaVersion              = Nothing+    , _schemaId                   = Nothing+    , _schemaRef                  = Nothing+    , _schemaDefinitions          = Nothing+    , _schemaOther                = mempty -  , _schemaMultipleOf           = Nothing-  , _schemaMaximum              = Nothing-  , _schemaExclusiveMaximum     = Nothing-  , _schemaMinimum              = Nothing-  , _schemaExclusiveMinimum     = Nothing+    , _schemaMultipleOf           = Nothing+    , _schemaMaximum              = Nothing+    , _schemaExclusiveMaximum     = Nothing+    , _schemaMinimum              = Nothing+    , _schemaExclusiveMinimum     = Nothing -  , _schemaMaxLength            = Nothing-  , _schemaMinLength            = Nothing-  , _schemaPattern              = Nothing+    , _schemaMaxLength            = Nothing+    , _schemaMinLength            = Nothing+    , _schemaPattern              = Nothing -  , _schemaMaxItems             = Nothing-  , _schemaMinItems             = Nothing-  , _schemaUniqueItems          = Nothing-  , _schemaItems                = Nothing-  , _schemaAdditionalItems      = Nothing+    , _schemaMaxItems             = Nothing+    , _schemaMinItems             = Nothing+    , _schemaUniqueItems          = Nothing+    , _schemaItems                = Nothing+    , _schemaAdditionalItems      = Nothing -  , _schemaMaxProperties        = Nothing-  , _schemaMinProperties        = Nothing-  , _schemaRequired             = Nothing-  , _schemaDependencies         = Nothing-  , _schemaProperties           = Nothing-  , _schemaPatternProperties    = Nothing-  , _schemaAdditionalProperties = Nothing+    , _schemaMaxProperties        = Nothing+    , _schemaMinProperties        = Nothing+    , _schemaRequired             = Nothing+    , _schemaDependencies         = Nothing+    , _schemaProperties           = Nothing+    , _schemaPatternProperties    = Nothing+    , _schemaAdditionalProperties = Nothing -  , _schemaEnum                 = Nothing-  , _schemaType                 = Nothing-  , _schemaAllOf                = Nothing-  , _schemaAnyOf                = Nothing-  , _schemaOneOf                = Nothing-  , _schemaNot                  = Nothing-  }+    , _schemaEnum                 = Nothing+    , _schemaType                 = Nothing+    , _schemaAllOf                = Nothing+    , _schemaAnyOf                = Nothing+    , _schemaOneOf                = Nothing+    , _schemaNot                  = Nothing+    }  instance FromJSON Schema where-  parseJSON = withObject "Schema" $ \o -> do-    a  <- o .:? "$schema"-    b  <- o .:? "id"-    c  <- o .:? "$ref"-    d  <- o .:? "definitions"-    e  <- parseJSON (Object (H.difference o internalSchemaHashMap))+    parseJSON = withObject "Schema" $ \o -> do+        a  <- o .:! "$schema"+        b  <- o .:! "id"+        c  <- o .:! "$ref"+        d  <- o .:! "definitions"+        e  <- parseJSON (Object (HM.difference o internalSchemaHashMap)) -    f  <- o .:? "multipleOf"-    g  <- o .:? "maximum"-    h  <- o .:? "exclusiveMaximum"-    i  <- o .:? "minimum"-    j  <- o .:? "exclusiveMinimum"+        f  <- o .:! "multipleOf"+        g  <- o .:! "maximum"+        h  <- o .:! "exclusiveMaximum"+        i  <- o .:! "minimum"+        j  <- o .:! "exclusiveMinimum" -    k  <- o .:? "maxLength"-    l  <- o .:? "minLength"-    m  <- o .:? "pattern"+        k  <- o .:! "maxLength"+        l  <- o .:! "minLength"+        m  <- o .:! "pattern" -    n  <- o .:? "maxItems"-    o' <- o .:? "minItems"-    p  <- o .:? "uniqueItems"-    q  <- o .:? "items"-    r  <- o .:? "additionalItems"+        n  <- o .:! "maxItems"+        o' <- o .:! "minItems"+        p  <- o .:! "uniqueItems"+        q  <- o .:! "items"+        r  <- o .:! "additionalItems" -    s  <- o .:? "maxProperties"-    t  <- o .:? "minProperties"-    u  <- o .:? "required"-    v  <- o .:? "dependencies"-    w  <- o .:? "properties"-    x  <- o .:? "patternProperties"-    y  <- o .:? "additionalProperties"+        s  <- o .:! "maxProperties"+        t  <- o .:! "minProperties"+        u  <- o .:! "required"+        v  <- o .:! "dependencies"+        w  <- o .:! "properties"+        x  <- o .:! "patternProperties"+        y  <- o .:! "additionalProperties" -    z  <- o .:? "enum"-    a2 <- o .:? "type"-    b2 <- fmap _unNonEmpty' <$> o .:? "allOf"-    c2 <- fmap _unNonEmpty' <$> o .:? "anyOf"-    d2 <- fmap _unNonEmpty' <$> o .:? "oneOf"-    e2 <- o .:? "not"-    pure Schema-      { _schemaVersion              = a-      , _schemaId                   = b-      , _schemaRef                  = c-      , _schemaDefinitions          = d-      , _schemaOther                = e+        z  <- o .:! "enum"+        a2 <- o .:! "type"+        b2 <- fmap _unNonEmpty' <$> o .:! "allOf"+        c2 <- fmap _unNonEmpty' <$> o .:! "anyOf"+        d2 <- fmap _unNonEmpty' <$> o .:! "oneOf"+        e2 <- o .:! "not"+        pure Schema+            { _schemaVersion              = a+            , _schemaId                   = b+            , _schemaRef                  = c+            , _schemaDefinitions          = d+            , _schemaOther                = e -      , _schemaMultipleOf           = f-      , _schemaMaximum              = g-      , _schemaExclusiveMaximum     = h-      , _schemaMinimum              = i-      , _schemaExclusiveMinimum     = j+            , _schemaMultipleOf           = f+            , _schemaMaximum              = g+            , _schemaExclusiveMaximum     = h+            , _schemaMinimum              = i+            , _schemaExclusiveMinimum     = j -      , _schemaMaxLength            = k-      , _schemaMinLength            = l-      , _schemaPattern              = m+            , _schemaMaxLength            = k+            , _schemaMinLength            = l+            , _schemaPattern              = m -      , _schemaMaxItems             = n-      , _schemaMinItems             = o'-      , _schemaUniqueItems          = p-      , _schemaItems                = q-      , _schemaAdditionalItems      = r+            , _schemaMaxItems             = n+            , _schemaMinItems             = o'+            , _schemaUniqueItems          = p+            , _schemaItems                = q+            , _schemaAdditionalItems      = r -      , _schemaMaxProperties        = s-      , _schemaMinProperties        = t-      , _schemaRequired             = u-      , _schemaDependencies         = v-      , _schemaProperties           = w-      , _schemaPatternProperties    = x-      , _schemaAdditionalProperties = y+            , _schemaMaxProperties        = s+            , _schemaMinProperties        = t+            , _schemaRequired             = u+            , _schemaDependencies         = v+            , _schemaProperties           = w+            , _schemaPatternProperties    = x+            , _schemaAdditionalProperties = y -      , _schemaEnum                 = z-      , _schemaType                 = a2-      , _schemaAllOf                = b2-      , _schemaAnyOf                = c2-      , _schemaOneOf                = d2-      , _schemaNot                  = e2-      }+            , _schemaEnum                 = z+            , _schemaType                 = a2+            , _schemaAllOf                = b2+            , _schemaAnyOf                = c2+            , _schemaOneOf                = d2+            , _schemaNot                  = e2+            }  instance ToJSON Schema where-  -- | The way we resolve JSON Pointers to embedded schemas is by-  -- serializing the containing schema to a value and then resolving the-  -- pointer against it. This means that FromJSON and ToJSON must be-  -- isomorphic.-  ---  -- This influences the design choices in the library. E.g. right now-  -- there are two false values for "exclusiveMaximum" -- Nothing and-  -- Just False. We could have condensed them down by using () instead-  -- of Bool for "exclusiveMaximum". This would have made writing schemas-  -- in haskell easier, but we could no longer round trip through/from-  -- JSON without losing information.-  toJSON s = Object $ H.union (mapMaybe ($ s) internalSchemaHashMap) (toJSON <$> _schemaOther s)-    where-      -- 'mapMaybe' is provided by unordered-containers after unordered-container-2.6.0.0,-      -- but until that is a little older (and has time to get into Stackage etc.)-      -- we use our own implementation.-      mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2-      mapMaybe f = fmap fromJust . H.filter isJust . fmap f+    -- | The way we resolve JSON Pointers to embedded schemas is by+    -- serializing the containing schema to a value and then resolving the+    -- pointer against it. This means that FromJSON and ToJSON must be+    -- isomorphic.+    --+    -- This influences the design choices in the library. E.g. right now+    -- there are two false values for "exclusiveMaximum" -- Nothing and+    -- Just False. We could have condensed them down by using () instead+    -- of Bool for "exclusiveMaximum". This would have made writing schemas+    -- in haskell easier, but we could no longer round trip through/from+    -- JSON without losing information.+    toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap)+                                 (toJSON <$> _schemaOther s)+      where+        -- 'mapMaybe' is provided by unordered-containers after+        -- unordered-container-2.6.0.0, but until that is a little older+        -- (and has time to get into Stackage etc.) we use our own+        -- implementation.+        mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+        mapMaybe f = fmap fromJust . HM.filter isJust . fmap f  -- | Internal. Separate from ToJSON because it's also used -- by FromJSON to determine what keys aren't official schema -- keys and therefor should be included in _schemaOther. internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value)-internalSchemaHashMap = H.fromList-  [ ("$schema"             , f _schemaVersion)-  , ("id"                  , f _schemaId)-  , ("$ref"                , f _schemaRef)-  , ("definitions"         , f _schemaDefinitions)+internalSchemaHashMap = HM.fromList+    [ ("$schema"             , f _schemaVersion)+    , ("id"                  , f _schemaId)+    , ("$ref"                , f _schemaRef)+    , ("definitions"         , f _schemaDefinitions) -  , ("multipleOf"          , f _schemaMultipleOf)-  , ("maximum"             , f _schemaMaximum)-  , ("exclusiveMaximum"    , f _schemaExclusiveMaximum)-  , ("minimum"             , f _schemaMinimum)-  , ("exclusiveMinimum"    , f _schemaExclusiveMinimum)+    , ("multipleOf"          , f _schemaMultipleOf)+    , ("maximum"             , f _schemaMaximum)+    , ("exclusiveMaximum"    , f _schemaExclusiveMaximum)+    , ("minimum"             , f _schemaMinimum)+    , ("exclusiveMinimum"    , f _schemaExclusiveMinimum) -  , ("maxLength"           , f _schemaMaxLength)-  , ("minLength"           , f _schemaMinLength)-  , ("pattern"             , f _schemaPattern)+    , ("maxLength"           , f _schemaMaxLength)+    , ("minLength"           , f _schemaMinLength)+    , ("pattern"             , f _schemaPattern) -  , ("maxItems"            , f _schemaMaxItems)-  , ("minItems"            , f _schemaMinItems)-  , ("uniqueItems"         , f _schemaUniqueItems)-  , ("items"               , f _schemaItems)-  , ("additionalItems"     , f _schemaAdditionalItems)+    , ("maxItems"            , f _schemaMaxItems)+    , ("minItems"            , f _schemaMinItems)+    , ("uniqueItems"         , f _schemaUniqueItems)+    , ("items"               , f _schemaItems)+    , ("additionalItems"     , f _schemaAdditionalItems) -  , ("maxProperties"       , f _schemaMaxProperties)-  , ("minProperties"       , f _schemaMinProperties)-  , ("required"            , f _schemaRequired)-  , ("dependencies"        , f _schemaDependencies)-  , ("properties"          , f _schemaProperties)-  , ("patternProperties"   , f _schemaPatternProperties)-  , ("additionalProperties", f _schemaAdditionalProperties)+    , ("maxProperties"       , f _schemaMaxProperties)+    , ("minProperties"       , f _schemaMinProperties)+    , ("required"            , f _schemaRequired)+    , ("dependencies"        , f _schemaDependencies)+    , ("properties"          , f _schemaProperties)+    , ("patternProperties"   , f _schemaPatternProperties)+    , ("additionalProperties", f _schemaAdditionalProperties) -  , ("enum"                , f _schemaEnum)-  , ("type"                , f _schemaType)-  , ("allOf"               , f (fmap NonEmpty' . _schemaAllOf))-  , ("anyOf"               , f (fmap NonEmpty' . _schemaAnyOf))-  , ("oneOf"               , f (fmap NonEmpty' . _schemaOneOf))-  , ("not"                 , f _schemaNot)-  ]+    , ("enum"                , f _schemaEnum)+    , ("type"                , f _schemaType)+    , ("allOf"               , f (fmap NonEmpty' . _schemaAllOf))+    , ("anyOf"               , f (fmap NonEmpty' . _schemaAnyOf))+    , ("oneOf"               , f (fmap NonEmpty' . _schemaOneOf))+    , ("not"                 , f _schemaNot)+    ]   where     f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value     f = (fmap.fmap) toJSON  instance Arbitrary Schema where-  arbitrary = sized f-    where-      maybeGen :: Gen a -> Gen (Maybe a)-      maybeGen a = oneof [pure Nothing, Just <$> a]+    arbitrary = sized f+      where+        maybeGen :: Gen a -> Gen (Maybe a)+        maybeGen a = oneof [pure Nothing, Just <$> a] -      maybeRecurse :: Int -> Gen a -> Gen (Maybe a)-      maybeRecurse n a-        | n < 1     = pure Nothing-        | otherwise = maybeGen $ resize (n `div` 10) a+        maybeRecurse :: Int -> Gen a -> Gen (Maybe a)+        maybeRecurse n a+            | n < 1     = pure Nothing+            | otherwise = maybeGen $ resize (n `div` 10) a -      f :: Int -> Gen Schema-      f n = do-        a  <- maybeGen arbitraryText-        b  <- maybeGen arbitraryText-        c  <- maybeGen arbitraryText-           -- NOTE: The next two fields are empty to generate cleaner schemas,-           -- but note that this means we don't test e.g. the invertability-           -- of these fields.-        d  <- pure Nothing -- _schemaDefinitions-        e  <- pure mempty -- _otherPairs+        f :: Int -> Gen Schema+        f n = do+            a  <- maybeGen arbitraryText+            b  <- maybeGen arbitraryText+            c  <- maybeGen arbitraryText+               -- NOTE: The next two fields are empty to generate cleaner schemas,+               -- but note that this means we don't test e.g. the invertability+               -- of these fields.+            d  <- pure Nothing -- _schemaDefinitions+            e  <- pure mempty -- _otherPairs -        f' <- maybeGen arbitraryPositiveScientific-        g  <- maybeGen arbitraryScientific-        h  <- arbitrary-        i  <- maybeGen arbitraryScientific-        j  <- arbitrary+            f' <- maybeGen arbitraryPositiveScientific+            g  <- maybeGen arbitraryScientific+            h  <- arbitrary+            i  <- maybeGen arbitraryScientific+            j  <- arbitrary -        k  <- maybeGen (getPositive <$> arbitrary)-        l  <- maybeGen (getPositive <$> arbitrary)-        m  <- maybeGen arbitraryText+            k  <- maybeGen (getPositive <$> arbitrary)+            l  <- maybeGen (getPositive <$> arbitrary)+            m  <- maybeGen arbitraryText -        n' <- maybeGen (getPositive <$> arbitrary)-        o  <- maybeGen (getPositive <$> arbitrary)-        p  <- arbitrary-        q  <- maybeRecurse n arbitrary-        r  <- maybeRecurse n arbitrary+            n' <- maybeGen (getPositive <$> arbitrary)+            o  <- maybeGen (getPositive <$> arbitrary)+            p  <- arbitrary+            q  <- maybeRecurse n arbitrary+            r  <- maybeRecurse n arbitrary -        s  <- maybeGen (getPositive <$> arbitrary)-        t  <- maybeGen (getPositive <$> arbitrary)-        u  <- arbitrary-        v  <- maybeRecurse n arbitraryHashMap-        w  <- maybeRecurse n arbitraryHashMap-        x  <- maybeRecurse n arbitraryHashMap-        y  <- maybeRecurse n arbitrary+            s  <- maybeGen (getPositive <$> arbitrary)+            t  <- maybeGen (getPositive <$> arbitrary)+            u  <- arbitrary+            v  <- maybeRecurse n arbitraryHashMap+            w  <- maybeRecurse n arbitraryHashMap+            x  <- maybeRecurse n arbitraryHashMap+            y  <- maybeRecurse n arbitrary -        z  <- arbitrary-        a2 <- arbitrary-        b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)-        c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)-        d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)-        e2 <- maybeRecurse n arbitrary-        pure Schema-          { _schemaVersion              = a-          , _schemaId                   = b-          , _schemaRef                  = c-          , _schemaDefinitions          = d-          , _schemaOther                = e+            z  <- arbitrary+            a2 <- arbitrary+            b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+            c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+            d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+            e2 <- maybeRecurse n arbitrary+            pure Schema+                { _schemaVersion              = a+                , _schemaId                   = b+                , _schemaRef                  = c+                , _schemaDefinitions          = d+                , _schemaOther                = e -          , _schemaMultipleOf           = f'-          , _schemaMaximum              = g-          , _schemaExclusiveMaximum     = h-          , _schemaMinimum              = i-          , _schemaExclusiveMinimum     = j+                , _schemaMultipleOf           = f'+                , _schemaMaximum              = g+                , _schemaExclusiveMaximum     = h+                , _schemaMinimum              = i+                , _schemaExclusiveMinimum     = j -          , _schemaMaxLength            = k-          , _schemaMinLength            = l-          , _schemaPattern              = m+                , _schemaMaxLength            = k+                , _schemaMinLength            = l+                , _schemaPattern              = m -          , _schemaMaxItems             = n'-          , _schemaMinItems             = o-          , _schemaUniqueItems          = p-          , _schemaItems                = q-          , _schemaAdditionalItems      = r+                , _schemaMaxItems             = n'+                , _schemaMinItems             = o+                , _schemaUniqueItems          = p+                , _schemaItems                = q+                , _schemaAdditionalItems      = r -          , _schemaMaxProperties        = s-          , _schemaMinProperties        = t-          , _schemaRequired             = u-          , _schemaDependencies         = v-          , _schemaProperties           = w-          , _schemaPatternProperties    = x-          , _schemaAdditionalProperties = y+                , _schemaMaxProperties        = s+                , _schemaMinProperties        = t+                , _schemaRequired             = u+                , _schemaDependencies         = v+                , _schemaProperties           = w+                , _schemaPatternProperties    = x+                , _schemaAdditionalProperties = y -          , _schemaEnum                 = z-          , _schemaType                 = a2-          , _schemaAllOf                = b2-          , _schemaAnyOf                = c2-          , _schemaOneOf                = d2-          , _schemaNot                  = e2-          }+                , _schemaEnum                 = z+                , _schemaType                 = a2+                , _schemaAllOf                = b2+                , _schemaAnyOf                = c2+                , _schemaOneOf                = d2+                , _schemaNot                  = e2+                }

@@ -0,0 +1,130 @@++module Data.JsonSchema.Draft4.Spec where++import           Import+-- Hiding is for GHCs before 7.10:+import           Prelude                        hiding (concat)++import           Data.Maybe                     (fromMaybe, isNothing)+import           Data.Profunctor                (Profunctor(..))++import           Data.JsonSchema.Draft4.Failure+import           Data.JsonSchema.Draft4.Schema  (Schema(..))+import           Data.JsonSchema.Fetch          (ReferencedSchemas(..),+                                                 SchemaWithURI(..))+import qualified Data.JsonSchema.Fetch          as FE+import           Data.JsonSchema.Types          (Spec(..))+import qualified Data.JsonSchema.Types          as JT+import qualified Data.Validator.Draft4          as D4+import qualified Data.Validator.Draft4.Any      as AN+import           Data.Validator.Reference       (updateResolutionScope)++embedded :: Schema -> ([Schema], [Schema])+embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s++validate+    :: ReferencedSchemas Schema+    -> SchemaWithURI Schema+    -> Value+    -> [Failure]+validate rs = continueValidating rs (AN.VisitedSchemas [(Nothing, Nothing)])++continueValidating+    :: ReferencedSchemas Schema+    -> AN.VisitedSchemas+    -> SchemaWithURI Schema+    -> Value+    -> [Failure]+continueValidating referenced visited sw =+    JT.validate (d4Spec referenced visited currentScope)+                (_swSchema sw)+  where+    currentScope :: Maybe Text+    currentScope = updateResolutionScope+                       (_swURI sw)+                       (_schemaId (_swSchema sw))++d4Spec+    :: ReferencedSchemas Schema+    -> AN.VisitedSchemas+    -> Maybe Text+    -> Spec Schema ValidatorChain+d4Spec referenced visited scope = Spec+    [ dimap+        (fmap D4.MultipleOf . _schemaMultipleOf)+        (const MultipleOf)+        D4.multipleOf+    , dimap+        (\s -> D4.MaximumContext (fromMaybe False (_schemaExclusiveMaximum s))+                 <$> _schemaMaximum s)+        maxE+        D4.maximumVal+    , dimap+        (\s -> D4.MinimumContext (fromMaybe False (_schemaExclusiveMinimum s))+                 <$> _schemaMinimum s)+        minE+        D4.minimumVal++    , dimap (fmap D4.MaxLength . _schemaMaxLength) (const MaxLength) D4.maxLength+    , dimap (fmap D4.MinLength . _schemaMinLength) (const MinLength) D4.minLength+    , dimap (fmap D4.PatternVal . _schemaPattern) (const PatternValidator) D4.patternVal++    , dimap (fmap D4.MaxItems . _schemaMaxItems) (const MaxItems) D4.maxItems+    , dimap (fmap D4.MinItems . _schemaMinItems) (const MinItems) D4.minItems+    , dimap (fmap D4.UniqueItems . _schemaUniqueItems) (const UniqueItems) D4.uniqueItems+    , dimap+        (\s -> D4.ItemsContext (_schemaAdditionalItems s) <$> _schemaItems s)+        itemsE+        (D4.items descend)+    , lmap (fmap D4.AdditionalItemsContext . _schemaAdditionalItems) D4.additionalItemsEmbedded+    , lmap (fmap D4.Definitions . _schemaDefinitions) D4.definitionsEmbedded++    , dimap (fmap D4.MaxProperties . _schemaMaxProperties) (const MaxProperties) D4.maxProperties+    , dimap (fmap D4.MinProperties . _schemaMinProperties) (const MinProperties) D4.minProperties+    , dimap (fmap D4.RequiredContext . _schemaRequired) (const Required) D4.required+    , dimap (fmap D4.DependenciesContext . _schemaDependencies) depsE (D4.dependencies descend)+    , dimap+        (\s -> D4.PropertiesContext+                 (_schemaPatternProperties s)+                 (_schemaAdditionalProperties s)+                 <$> _schemaProperties s)+        propE+        (D4.properties descend)+    , dimap+        (\s -> D4.PatternPropertiesContext+                 (isNothing (_schemaProperties s))+                 (_schemaAdditionalProperties s)+                 <$> _schemaPatternProperties s)+        patPropE+        (D4.patternProperties descend)+    , dimap+        (\s -> D4.AdditionalPropertiesContext+                 (isNothing (_schemaProperties s)+                    && isNothing (_schemaPatternProperties s))+                 <$> _schemaAdditionalProperties s)+        addPropE+        (D4.additionalProperties descend)++    , dimap+        (\s -> D4.Ref <$> _schemaRef s)+        refE+        (D4.ref visited scope (FE.getReference referenced) refVal)+    , dimap (fmap D4.EnumContext . _schemaEnum) (const Enum) D4.enumVal+    , dimap (fmap D4.TypeContext . _schemaType) (const TypeValidator) D4.typeVal+    , dimap (fmap D4.AllOf . _schemaAllOf) AllOf (D4.allOf lateral)+    , dimap (fmap D4.AnyOf . _schemaAnyOf) (const AnyOf) (D4.anyOf lateral)+    , dimap (fmap D4.OneOf . _schemaOneOf) (const OneOf) (D4.oneOf lateral)+    , dimap (fmap D4.NotVal . _schemaNot) (const NotValidator) (D4.notVal lateral)+    ]+  where+    refVal :: AN.VisitedSchemas -> Maybe Text -> Schema -> Value -> [Failure]+    refVal newVisited newScope schema =+        continueValidating referenced newVisited (SchemaWithURI schema newScope)++    descend :: Schema -> Value -> [Failure]+    descend schema =+        continueValidating referenced mempty (SchemaWithURI schema scope)++    lateral :: Schema -> Value -> [Failure]+    lateral schema =+        continueValidating referenced visited (SchemaWithURI schema scope)

@@ -1,83 +1,104 @@-{-# LANGUAGE ScopedTypeVariables #-}  module Data.JsonSchema.Fetch where +import           Import+-- Hiding is for GHCs before 7.10:+import           Prelude                  hiding (concat, sequence)+ import           Control.Arrow            (left) import           Control.Exception        (catch)+import           Control.Monad            (foldM) import qualified Data.ByteString.Lazy     as LBS import qualified Data.ByteString          as BS import qualified Data.HashMap.Strict      as H import qualified Data.Text                as T-import           Network.HTTP.Client+import qualified Network.HTTP.Client      as NC  import           Data.Validator.Reference (resolveReference,                                            updateResolutionScope)-import           Import --- For GHCs before 7.10:-import           Prelude                  hiding (concat, sequence)- -------------------------------------------------- -- * Types -------------------------------------------------- -data Spec schema = Spec-  { _ssEmbedded :: schema -> [schema]-  , _ssGetId    :: schema -> Maybe Text-  , _ssGetRef   :: schema -> Maybe Text-  }--data SchemaWithURI schema = SchemaWithURI-  { _swSchema :: !schema-  , _swURI    :: !(Maybe Text)-  -- ^ Must not include a URI fragment, e.g. use-  -- "http://example.com/foo" not "http://example.com/foo#bar".-  ---  -- This is the URI identifying the document containing the schema.-  -- It's different than the schema's "id" field, which controls scope-  -- when resolving references contained in the schema.+-- | This is all the fetching functions need to know about a particular+-- JSON Schema draft, e.g. JSON Schema Draft 4.+data FetchInfo schema = FetchInfo+    { _fiEmbedded :: schema -> ([schema], [schema])+    , _fiId       :: schema -> Maybe Text+    , _fiRef      :: schema -> Maybe Text+    } -  -- TODO: Make the no URI fragment requirement unnecessary.-  } deriving (Eq, Show)+data ReferencedSchemas schema = ReferencedSchemas+    { _rsStarting  :: !schema+      -- ^ Used to resolve relative references when we don't know what the scope+      -- of the current schema is. This only happens with starting schemas+      -- because if we're using a remote schema we had to know its URI in order+      -- to fetch it.+      --+      -- Tracking the starting schema (instead of just resolving the reference to+      -- the current schema being used for validation) is necessary for cases+      -- where schemas are embedded inside one another. For instance in this+      -- case not distinguishing the starting and "foo" schemas sends the code+      -- into an infinite loop:+      --+      -- {+      --   "additionalProperties": false,+      --   "properties": {+      --     "foo": {+      --       "$ref": "#"+      --     }+      --   }+      -- }+    , _rsSchemaMap :: !(URISchemaMap schema)+    } deriving (Eq, Show)  -- | Keys are URIs (without URI fragments). type URISchemaMap schema = HashMap Text schema -data ReferencedSchemas schema = ReferencedSchemas-  { _rsStarting  :: !schema-  -- ^ Used to resolve relative references.-  , _rsSchemaMap :: !(URISchemaMap schema)-  } deriving (Eq, Show)+data SchemaWithURI schema = SchemaWithURI+    { _swSchema :: !schema+    , _swURI    :: !(Maybe Text)+      -- ^ This is the URI identifying the document containing the schema.+      -- It's different than the schema's "id" field, which controls scope+      -- when resolving references contained in the schema. +      -- TODO: Make the no URI fragment requirement unnecessary.+    } deriving (Eq, Show)++getReference :: ReferencedSchemas schema -> Maybe Text -> Maybe schema+getReference referenced Nothing  = Just (_rsStarting referenced)+getReference referenced (Just t) = H.lookup t (_rsSchemaMap referenced)+ -------------------------------------------------- -- * Fetch via HTTP --------------------------------------------------  data HTTPFailure-  = HTTPParseFailure   Text-  | HTTPRequestFailure HttpException-  deriving Show+    = HTTPParseFailure   Text+    | HTTPRequestFailure NC.HttpException+    deriving Show  -- | Take a schema. Retrieve every document either it or its subschemas -- include via the "$ref" keyword. referencesViaHTTP'-  :: forall schema. FromJSON schema-  => Spec schema-  -> SchemaWithURI schema-  -> IO (Either HTTPFailure (ReferencedSchemas schema))-referencesViaHTTP' spec sw = do-  manager <- newManager defaultManagerSettings-  let f = referencesMethodAgnostic (get manager) spec sw-  catch (left HTTPParseFailure <$> f) handler+    :: forall schema. FromJSON schema+    => FetchInfo schema+    -> SchemaWithURI schema+    -> IO (Either HTTPFailure (URISchemaMap schema))+referencesViaHTTP' info sw = do+    manager <- NC.newManager NC.defaultManagerSettings+    let f = referencesMethodAgnostic (get manager) info sw+    catch (left HTTPParseFailure <$> f) handler   where-    get :: Manager -> Text -> IO LBS.ByteString+    get :: NC.Manager -> Text -> IO LBS.ByteString     get man url = do-      request <- parseUrl (T.unpack url)-      responseBody <$> httpLbs request man+        request <- NC.parseUrlThrow (T.unpack url)+        NC.responseBody <$> NC.httpLbs request man      handler-      :: HttpException-      -> IO (Either HTTPFailure (ReferencedSchemas schema))+        :: NC.HttpException+        -> IO (Either HTTPFailure (URISchemaMap schema))     handler = pure . Left . HTTPRequestFailure  --------------------------------------------------@@ -85,26 +106,26 @@ --------------------------------------------------  data FilesystemFailure-  = FSParseFailure Text-  | FSReadFailure  IOError-  deriving Show+    = FSParseFailure Text+    | FSReadFailure  IOError+    deriving (Show, Eq)  referencesViaFilesystem'-  :: forall schema. FromJSON schema-  => Spec schema-  -> SchemaWithURI schema-  -> IO (Either FilesystemFailure (ReferencedSchemas schema))-referencesViaFilesystem' spec sw = catch (left FSParseFailure <$> f) handler+    :: forall schema. FromJSON schema+    => FetchInfo schema+    -> SchemaWithURI schema+    -> IO (Either FilesystemFailure (URISchemaMap schema))+referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler   where-    f :: IO (Either Text (ReferencedSchemas schema))-    f = referencesMethodAgnostic readFile' spec sw+    f :: IO (Either Text (URISchemaMap schema))+    f = referencesMethodAgnostic readFile' info sw      readFile' :: Text -> IO LBS.ByteString     readFile' = fmap LBS.fromStrict . BS.readFile . T.unpack      handler-      :: IOError-      -> IO (Either FilesystemFailure (ReferencedSchemas schema))+        :: IOError+        -> IO (Either FilesystemFailure (URISchemaMap schema))     handler = pure . Left . FSReadFailure  --------------------------------------------------@@ -115,59 +136,59 @@ -- schemas is provided by the user. This allows restrictions to be added, -- e.g. rejecting non-local URIs. referencesMethodAgnostic-  :: forall schema. FromJSON schema-  => (Text -> IO LBS.ByteString)-  -> Spec schema-  -> SchemaWithURI schema-  -> IO (Either Text (ReferencedSchemas schema))-referencesMethodAgnostic fetchRef spec sw =-  (fmap.fmap) (ReferencedSchemas (_swSchema sw))-              (foldFunction fetchRef spec mempty sw)+    :: forall schema. FromJSON schema+    => (Text -> IO LBS.ByteString)+    -> FetchInfo schema+    -> SchemaWithURI schema+    -> IO (Either Text (URISchemaMap schema))+referencesMethodAgnostic fetchRef info =+    getRecursiveReferences fetchRef info mempty -foldFunction-  :: forall schema. FromJSON schema-  => (Text -> IO LBS.ByteString)-  -> Spec schema-  -> URISchemaMap schema-  -> SchemaWithURI schema-  -> IO (Either Text (URISchemaMap schema))-foldFunction fetchRef spec@(Spec _ _ getRef) referenced sw =-  foldlM f (Right referenced) (includeSubschemas spec sw)+getRecursiveReferences+    :: forall schema. FromJSON schema+    => (Text -> IO LBS.ByteString)+    -> FetchInfo schema+    -> URISchemaMap schema+    -> SchemaWithURI schema+    -> IO (Either Text (URISchemaMap schema))+getRecursiveReferences fetchRef info referenced sw =+    foldM f (Right referenced) (includeSubschemas info sw)   where     f :: Either Text (URISchemaMap schema)       -> SchemaWithURI schema       -> IO (Either Text (URISchemaMap schema))     f (Left e) _                            = pure (Left e)     f (Right g) (SchemaWithURI schema mUri) =-      case newRef of-        Nothing  -> pure (Right g)-        Just uri -> do-          bts <- fetchRef uri-          case eitherDecode bts of-            Left e     -> pure . Left . T.pack $ e-            Right schm -> foldFunction fetchRef spec (H.insert uri schm g)-                                       (SchemaWithURI schm (Just uri))+        case newRef of+            Nothing  -> pure (Right g)+            Just uri -> do+                bts <- fetchRef uri+                case eitherDecode bts of+                    Left e     -> pure . Left . T.pack $ e+                    Right schm -> getRecursiveReferences+                                      fetchRef info (H.insert uri schm g)+                                      (SchemaWithURI schm (Just uri))       where         newRef :: Maybe Text         newRef-          | Just (Just uri,_) <- resolveReference mUri <$> getRef schema-            = case H.lookup uri g of-                Nothing -> Just uri-                Just _  -> Nothing+          | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema+              = case H.lookup uri g of+                    Nothing -> Just uri+                    Just _  -> Nothing           | otherwise = Nothing  -- | Return the schema passed in as an argument, as well as every -- subschema contained within it. includeSubschemas-  :: forall schema.-     Spec schema-  -> SchemaWithURI schema-  -> [SchemaWithURI schema]-includeSubschemas spec@(Spec embedded getId _) (SchemaWithURI schema mUri) =-  SchemaWithURI schema mUri-  : (includeSubschemas spec =<< subSchemas)+    :: forall schema.+       FetchInfo schema+    -> SchemaWithURI schema+    -> [SchemaWithURI schema]+includeSubschemas info (SchemaWithURI schema mUri) =+    SchemaWithURI schema mUri+    : (includeSubschemas info =<< subSchemas)   where     subSchemas :: [SchemaWithURI schema]     subSchemas =-      (\a -> SchemaWithURI a (updateResolutionScope mUri (getId schema)))-        <$> embedded schema+      (\a -> SchemaWithURI a (updateResolutionScope mUri (_fiId info schema)))+         <$> uncurry (<>) (_fiEmbedded info schema)

@@ -0,0 +1,38 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.JsonSchema.Types where++import           Prelude+import           Import++import           Data.Validator.Failure (Fail)+import           Data.Validator.Types   (Validator(..))++newtype Spec schema err+    = Spec { _unSpec :: [Validator schema schema err] }++-- | Return a schema's immediate subschemas.+--+-- The first list is subschemas validating the same level of the document,+-- the second list is subschemas validating lower levels (see+-- 'Data.Validator.Types.Fail' for a full explanation).+embedded :: Spec schema a -> schema -> ([schema], [schema])+embedded spec schema =+    let embeds = (\val -> _embedded val schema) <$> _unSpec spec+    in foldl' (\(a,b) (x,y) -> (x <> a, y <> b)) (mempty, mempty) embeds++validate+    :: Spec schema err+    -> schema+    -> Value+    -> [Fail err]+validate spec schema v = _unSpec spec >>= (\val -> _validate val schema v)++-- | A basic schema type that doesn't impose much structure.+--+-- 'Data.JsonSchema.Draft4' doesn't use this, but instead uses the one+-- defined in 'Data.JsonSchema.Draft4.Schema' to make it easier to write+-- draft 4 schemas in Haskell.+newtype Schema+    = Schema { _unSchema :: HashMap Text Value }+    deriving (Eq, Show, FromJSON, ToJSON)

@@ -1,8 +1,551 @@+-- | 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 (module Export) where+module Data.Validator.Draft4 where -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           Prelude+import           Import++import           Data.Aeson.Types             (Parser)+import qualified Data.HashMap.Strict          as HM+import           Data.List.NonEmpty           (NonEmpty)+import qualified Data.List.NonEmpty           as NE+import           Data.Maybe                   (catMaybes, isNothing,+                                               maybe, maybeToList)+import           Data.Scientific              (Scientific)+import           Data.Text                    (Text)++import qualified Data.Validator.Draft4.Any    as AN+import qualified Data.Validator.Draft4.Array  as AR+import qualified Data.Validator.Draft4.Number as NU+import qualified Data.Validator.Draft4.Object as OB+import qualified Data.Validator.Draft4.String as ST+import           Data.Validator.Failure       (Fail(..))+import           Data.Validator.Types         (Validator(..))+import           Data.Validator.Utils         (fromJSONEither)++-- | For internal use.+run :: FromJSON b => (a -> b -> [c]) -> Maybe a -> Value -> [c]+run _ Nothing _  = mempty+run f (Just a) b =+    case fromJSONEither b of+        Left _  -> mempty+        Right c -> f a c++-- | For internal use.+noEmbedded :: a -> ([b], [b])+noEmbedded = const (mempty, mempty)++--------------------------------------------------+-- * Numbers+--------------------------------------------------++newtype MultipleOf+    = MultipleOf { _unMultipleOf :: Scientific }+    deriving (Eq, Show)++instance FromJSON MultipleOf where+    parseJSON = withObject "MultipleOf" $ \o ->+        MultipleOf <$> o .: "multipleOf"++multipleOf :: Validator a (Maybe MultipleOf) ()+multipleOf =+    Validator+        noEmbedded+        (run (fmap maybeToList . NU.multipleOf . _unMultipleOf))++data MaximumContext+    = MaximumContext Bool Scientific+    deriving (Eq, Show)++instance FromJSON MaximumContext where+    parseJSON = withObject "MaximumContext" $ \o -> MaximumContext+        <$> o .:! "exclusiveMaximum" .!= False+        <*> o .: "maximum"++maximumVal :: Validator a (Maybe MaximumContext) NU.MaximumInvalid+maximumVal =+    Validator+        noEmbedded+        (run (\(MaximumContext a b) -> maybeToList . NU.maximumVal a b))++data MinimumContext+    = MinimumContext Bool Scientific+    deriving (Eq, Show)++instance FromJSON MinimumContext where+    parseJSON = withObject "MinimumContext" $ \o -> MinimumContext+        <$> o .:! "exclusiveMinimum" .!= False+        <*> o .: "minimum"++minimumVal :: Validator a (Maybe MinimumContext) NU.MinimumInvalid+minimumVal =+    Validator+        noEmbedded+        (run (\(MinimumContext a b) -> maybeToList . NU.minimumVal a b))++--------------------------------------------------+-- * Strings+--------------------------------------------------++newtype MaxLength+    = MaxLength { _unMaxLength :: Int }+    deriving (Eq, Show)++instance FromJSON MaxLength where+    parseJSON = withObject "MaxLength" $ \o ->+        MaxLength <$> o .: "maxLength"++maxLength :: Validator a (Maybe MaxLength) ()+maxLength =+    Validator+        noEmbedded+        (run (fmap maybeToList . ST.maxLength . _unMaxLength))++newtype MinLength+    = MinLength { _unMinLength :: Int }+    deriving (Eq, Show)++instance FromJSON MinLength where+    parseJSON = withObject "MinLength" $ \o ->+        MinLength <$> o .: "minLength"++minLength :: Validator a (Maybe MinLength) ()+minLength =+    Validator+        noEmbedded+        (run (fmap maybeToList . ST.minLength . _unMinLength))++newtype PatternVal+    = PatternVal { _unPatternVal :: Text }+    deriving (Eq, Show)++instance FromJSON PatternVal where+    parseJSON = withObject "PatternVal" $ \o ->+        PatternVal <$> o .: "pattern"++patternVal :: Validator a (Maybe PatternVal) ()+patternVal =+    Validator+        noEmbedded+        (run (fmap maybeToList . ST.patternVal . _unPatternVal))++--------------------------------------------------+-- * Arrays+--------------------------------------------------++newtype MaxItems+    = MaxItems { _unMaxItems :: Int }+    deriving (Eq, Show)++instance FromJSON MaxItems where+    parseJSON = withObject "MaxItems" $ \o ->+        MaxItems <$> o .: "maxItems"++maxItems :: Validator a (Maybe MaxItems) ()+maxItems =+    Validator+        noEmbedded+        (run (fmap maybeToList . AR.maxItems . _unMaxItems))++newtype MinItems+    = MinItems { _unMinItems :: Int }+    deriving (Eq, Show)++instance FromJSON MinItems where+    parseJSON = withObject "MinItems" $ \o ->+        MinItems <$> o .: "minItems"++minItems :: Validator a (Maybe MinItems) ()+minItems =+    Validator+        noEmbedded+        (run (fmap maybeToList . AR.minItems . _unMinItems))++newtype UniqueItems+    = UniqueItems { _unUniqueItems :: Bool }+    deriving (Eq, Show)++instance FromJSON UniqueItems where+    parseJSON = withObject "UniqueItems" $ \o ->+        UniqueItems <$> o .: "uniqueItems"++uniqueItems :: Validator a (Maybe UniqueItems) ()+uniqueItems =+    Validator+        noEmbedded+        (run (fmap maybeToList . AR.uniqueItems . _unUniqueItems))++data ItemsContext schema =+    ItemsContext+        (Maybe (AR.AdditionalItems schema))+        (AR.Items schema)+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (ItemsContext schema) where+    parseJSON = withObject "ItemsContext" $ \o -> ItemsContext+        <$> o .:! "additionalItems"+        <*> o .: "items"++items+    :: (schema -> Value -> [Fail err])+    -> Validator schema (Maybe (ItemsContext schema)) (AR.ItemsInvalid err)+items f =+    Validator+        (\a -> case a of+                   Nothing -> mempty+                   Just (ItemsContext _ b) ->+                       case b of+                           AR.ItemsObject c -> (mempty, pure c)+                           AR.ItemsArray cs -> (mempty, cs))+        (run (\(ItemsContext a b) -> AR.items f a b))++newtype AdditionalItemsContext schema+    = AdditionalItemsContext+        { _unAdditionalItemsContext :: AR.AdditionalItems schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AdditionalItemsContext schema) where+    parseJSON = withObject "AdditionalItemsContext" $ \o ->+        AdditionalItemsContext <$> o .: "additionalItems"++-- | Since 'items' will always take care of validating 'additionalItems'+-- as well, the actual validation side of 'additionalItemsEmbedded' is+-- disabled.+additionalItemsEmbedded+    :: Validator+           schema+           (Maybe (AdditionalItemsContext schema))+           err+additionalItemsEmbedded=+    Validator+        (\a -> case a of+                   Just (AdditionalItemsContext (AR.AdditionalObject b)) ->+                       (mempty, pure b)+                   _ -> (mempty, mempty))+        (const (const mempty))++newtype Definitions schema+    = Definitions { _unDefinitions :: HashMap Text schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (Definitions schema) where+    parseJSON = withObject "Definitions" $ \o ->+        Definitions <$> o .: "definitions"++-- | Placing this here since it's similar to @"additionalItems"@.+-- in that its validator doesn't run.+--+-- TODO: Add tests to the language agnostic test suite for both+-- @"additionalItems"@ and this.+definitionsEmbedded+    :: Validator+           schema+           (Maybe (Definitions schema))+           err+definitionsEmbedded =+    Validator+        (\a -> case a of+                 Just (Definitions b) -> (mempty, HM.elems b)+                 Nothing              -> (mempty, mempty))+        (const (const mempty))++--------------------------------------------------+-- * Objects+--------------------------------------------------++newtype MaxProperties+    = MaxProperties { _unMaxProperties :: Int }+    deriving (Eq, Show)++instance FromJSON MaxProperties where+    parseJSON = withObject "MaxProperties" $ \o ->+        MaxProperties <$> o .: "maxProperties"++maxProperties :: Validator a (Maybe MaxProperties) ()+maxProperties =+    Validator+        noEmbedded+        (run (fmap maybeToList . OB.maxProperties . _unMaxProperties))++newtype MinProperties+    = MinProperties { _unMinProperties :: Int }+    deriving (Eq, Show)++instance FromJSON MinProperties where+    parseJSON = withObject "MinProperties" $ \o ->+        MinProperties <$> o .: "minProperties"++minProperties :: Validator a (Maybe MinProperties) ()+minProperties =+    Validator+        noEmbedded+        (run (fmap maybeToList . OB.minProperties . _unMinProperties))++newtype RequiredContext+    = RequiredContext { _unRequiredContext :: OB.Required }+    deriving (Eq, Show)++instance FromJSON RequiredContext where+    parseJSON = withObject "RequiredContext" $ \o ->+        RequiredContext <$> o .: "required"++required :: Validator a (Maybe RequiredContext) ()+required =+    Validator+        noEmbedded+        (run (fmap maybeToList . OB.required . _unRequiredContext))++newtype DependenciesContext schema+    = DependenciesContext+           { _unDependenciesContext :: HashMap Text (OB.Dependency schema) }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (DependenciesContext schema) where+    parseJSON = withObject "DependenciesContext" $ \o ->+        DependenciesContext <$> o .: "dependencies"++dependencies+    :: (schema -> Value -> [Fail err])+    -> Validator+           schema+           (Maybe (DependenciesContext schema))+           (OB.DependencyInvalid err)+dependencies f =+    Validator+        (maybe mempty ( (\a -> (mempty, a))+                      . catMaybes . fmap checkDependency+                      . HM.elems . _unDependenciesContext+                      ))+        (run (OB.dependencies f . _unDependenciesContext))+  where+    checkDependency :: OB.Dependency schema -> Maybe schema+    checkDependency (OB.PropertyDependency _) = Nothing+    checkDependency (OB.SchemaDependency s)   = Just s++data PropertiesContext schema+    = PropertiesContext+          (Maybe (HashMap Text schema))+          (Maybe (OB.AdditionalProperties schema))+          (HashMap Text schema)+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (PropertiesContext schema) where+    parseJSON = withObject "PropertiesContext" $ \o -> PropertiesContext+        <$> o .:! "patternProperties"+        <*> o .:! "additionalProperties"+        <*> o .: "properties"++properties+    :: (schema -> Value -> [Fail err])+    -> Validator+           schema+           (Maybe (PropertiesContext schema))+           (OB.PropertiesInvalid err)+properties f =+    Validator+        (\a -> case a of+                   Just (PropertiesContext _ _ b) -> (mempty, HM.elems b)+                   Nothing                        -> (mempty, mempty))+        (run (\(PropertiesContext a b c) -> OB.properties f a b c))++-- | The first argument is whether the validator should be run.+-- If @"properties"@ exists it will be parsed to 'False'.+data PatternPropertiesContext schema+    = PatternPropertiesContext+          Bool+          (Maybe (OB.AdditionalProperties schema))+          (HashMap Text schema)+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (PatternPropertiesContext schema) where+    parseJSON = withObject "PatternPropertiesContext" $ \o ->+        PatternPropertiesContext+            <$> shouldRun o+            <*> o .:! "additionalProperties"+            <*> o .: "patternProperties"+      where+        shouldRun :: HashMap Text Value -> Parser Bool+        shouldRun o = do+            a <- o .:! "properties"+            pure $ isNothing (a :: Maybe (HashMap Text schema))++patternProperties+    :: (schema -> Value -> [Fail err])+    -> Validator+           schema+           (Maybe (PatternPropertiesContext schema))+           (OB.PatternPropertiesInvalid err)+patternProperties f =+    Validator+        (\a -> case a of+                   Just (PatternPropertiesContext _ _ b) -> (mempty, HM.elems b)+                   Nothing                               -> (mempty, mempty))+        (run (\(PatternPropertiesContext a b c) -> OB.patternProperties f a b c))++-- | The first argument is whether the validator should be run.+-- If @"properties"@ or @"patternProperties"@ exist it will be parsed+-- to 'False'.+data AdditionalPropertiesContext schema+    = AdditionalPropertiesContext+          Bool+          (OB.AdditionalProperties schema)+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AdditionalPropertiesContext schema) where+    parseJSON = withObject "AdditionalPropertiesContext" $ \o ->+        AdditionalPropertiesContext+            <$> shouldRun o+            <*> o .: "additionalProperties"+      where+        shouldRun :: HashMap Text Value -> Parser Bool+        shouldRun o = do+            a <- o .:! "properties"+            b <- o .:! "patternProperties"+            pure $ isNothing (a :: Maybe (HashMap Text schema))+                && isNothing (b :: Maybe (HashMap Text schema))++additionalProperties+    :: (schema -> Value -> [Fail err])+    -> Validator+           schema+           (Maybe (AdditionalPropertiesContext schema))+           (OB.AdditionalPropertiesInvalid err)+additionalProperties f =+    Validator+        (\a -> case a of+                   Nothing -> mempty+                   Just (AdditionalPropertiesContext _ b) ->+                       case b of+                           OB.AdditionalPropertiesBool _   -> (mempty, mempty)+                           OB.AdditionalPropertiesObject c -> (mempty, pure c))+        (run (\(AdditionalPropertiesContext a b) -> OB.additionalProperties f a b))++--------------------------------------------------+-- * Any+--------------------------------------------------++newtype Ref+    = Ref { _unRef :: Text }+    deriving (Eq, Show)++instance FromJSON Ref where+    parseJSON = withObject "Ref" $ \o ->+        Ref <$> o .: "$ref"++ref+    :: (FromJSON schema, ToJSON schema)+    => AN.VisitedSchemas+    -> Maybe Text+    -> (Maybe Text -> Maybe schema)+    -> (AN.VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err])+    -> Validator a (Maybe Ref) (AN.RefInvalid err)+ref visited scope getRef f =+    Validator+        noEmbedded+        (run (AN.ref visited scope getRef f . _unRef))++newtype EnumContext+    = EnumContext { _unEnumContext :: AN.EnumVal }+    deriving (Eq, Show)++instance FromJSON EnumContext where+    parseJSON = withObject "EnumContext" $ \o ->+        EnumContext <$> o .: "enum"++enumVal :: Validator a (Maybe EnumContext) ()+enumVal =+    Validator+        noEmbedded+        (run (fmap maybeToList . AN.enumVal . _unEnumContext))++newtype TypeContext+    = TypeContext { _unTypeContext :: AN.TypeVal }+    deriving (Eq, Show)++instance FromJSON TypeContext where+    parseJSON = withObject "TypeContext" $ \o ->+        TypeContext <$> o .: "type"++typeVal :: Validator a (Maybe TypeContext) ()+typeVal =+    Validator+        noEmbedded+        (run (fmap maybeToList . AN.typeVal . _unTypeContext))++newtype AllOf schema+    = AllOf { _unAllOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AllOf schema) where+    parseJSON = withObject "AllOf" $ \o ->+        AllOf <$> o .: "allOf"++allOf+    :: (schema -> Value -> [Fail err])+    -> Validator schema (Maybe (AllOf schema)) err+allOf f =+    Validator+        (\a -> case a of+                   Just (AllOf b) -> (NE.toList b, mempty)+                   Nothing        -> (mempty, mempty))+        (run (AN.allOf f . _unAllOf))++newtype AnyOf schema+    = AnyOf { _unAnyOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AnyOf schema) where+    parseJSON = withObject "AnyOf" $ \o ->+        AnyOf <$> o .: "anyOf"++anyOf+    :: ToJSON schema+    => (schema -> Value -> [Fail err])+    -> Validator schema (Maybe (AnyOf schema)) ()+anyOf f =+    Validator+        (\a -> case a of+                 Just (AnyOf b) -> (NE.toList b, mempty)+                 Nothing        -> (mempty, mempty))+        (run (fmap maybeToList . AN.anyOf f . _unAnyOf))++newtype OneOf schema+    = OneOf { _unOneOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (OneOf schema) where+    parseJSON = withObject "OneOf" $ \o ->+        OneOf <$> o .: "oneOf"++oneOf+    :: ToJSON schema+    => (schema -> Value -> [Fail err])+    -> Validator schema (Maybe (OneOf schema)) ()+oneOf f =+    Validator+        (\a -> case a of+                   Just (OneOf b) -> (NE.toList b, mempty)+                   Nothing        -> (mempty, mempty))+        (run (fmap maybeToList . AN.oneOf f . _unOneOf))++newtype NotVal schema+    = NotVal { _unNotVal :: schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (NotVal schema) where+    parseJSON = withObject "NotVal" $ \o ->+        NotVal <$> o .: "not"++notVal+    :: ToJSON schema+    => (schema -> Value -> [Fail err])+    -> Validator schema (Maybe (NotVal schema)) ()+notVal f =+    Validator+        (\a -> case a of+                   Just (NotVal b) -> (pure b, mempty)+                   Nothing         -> (mempty, mempty))+        (run (fmap maybeToList . AN.notVal f . _unNotVal))

@@ -1,42 +1,67 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Data.Validator.Draft4.Any where +import           Import+-- Hiding is for GHCs before 7.10:+import           Prelude hiding           (any, elem)+ import           Control.Monad import           Data.Aeson.Types         (Parser) import           Data.List.NonEmpty       (NonEmpty)-import qualified Data.List.NonEmpty       as N+import qualified Data.List.NonEmpty       as NE import           Data.Maybe-import           Data.Scientific+import qualified Data.Scientific          as SCI import           Data.Set                 (Set) import qualified Data.Set                 as S -import           Data.Validator.Failure-import           Data.Validator.Utils-import           Data.Validator.Reference (resolveFragment, resolveReference)-import           Import---- For GHCs before 7.10:-import           Prelude hiding           (any, elem)+import           Data.Validator.Failure   (Fail(..))+import qualified Data.Validator.Utils     as UT+import           Data.Validator.Reference (URIBaseAndFragment,+                                           resolveFragment, resolveReference)  -------------------------------------------------- -- * $ref -------------------------------------------------- --- | Will return 'Nothing' if the reference can't be resolved.+data RefInvalid err+    = RefResolution+    | RefLoop+    | RefInvalid err+    deriving (Eq, Show)++newtype VisitedSchemas+    = VisitedSchemas { _unVisited :: [URIBaseAndFragment] }+    deriving (Eq, Show, Monoid)+ ref-  :: forall err schema. (FromJSON schema, ToJSON schema, Show schema)-  => Maybe Text-  -> (Maybe Text -> Maybe schema)-  -> (Maybe Text -> schema -> Value -> [Failure err])-  -> Text-  -> Value-  -> Maybe [Failure err]-ref scope getRef f reference x = do-  let (mUri, mFragment) = resolveReference scope reference-  schema <- getRef mUri-  s      <- resolveFragment mFragment schema-  Just (f mUri s x)+    :: forall err schema. (FromJSON schema, ToJSON schema)+    => VisitedSchemas+    -> Maybe Text+    -> (Maybe Text -> Maybe schema)+    -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err])+    -> Text+    -> Value+    -> [Fail (RefInvalid err)]+ref visited scope getRef f reference x+    | (mUri, mFragment) `elem` _unVisited visited =+        pure $ Failure RefLoop (toJSON reference) mempty x+    | otherwise =+        case getRef mUri of+            Nothing     -> pure failureDNE+            Just schema ->+                case resolveFragment mFragment schema of+                    Nothing -> pure failureDNE+                    Just s  ->+                        let newVisited = (VisitedSchemas [(mUri, mFragment)]+                                      <> visited)+                        in fmap RefInvalid <$> f newVisited mUri s x+  where+    (mUri, mFragment) = resolveReference scope reference +    failureDNE :: Fail (RefInvalid err)+    failureDNE = Failure RefResolution (toJSON reference) mempty x+ -------------------------------------------------- -- * enum --------------------------------------------------@@ -51,128 +76,144 @@ -- NOTE: We don't enforce the uniqueness constraint in the haskell code, -- but we do in the 'FromJSON' instance. newtype EnumVal-  = EnumVal { _unEnumVal :: NonEmpty Value }-  -- Given a choice, we'd prefer to enforce uniqueness through the type-  -- system over having at least one element. To use a 'Set' though we'd-  -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)-  -- and we'd rather not make users mess with 'OrdValue'.-  deriving (Eq, Show)+    = EnumVal { _unEnumVal :: NonEmpty Value }+    -- Given a choice, we'd prefer to enforce uniqueness through the type+    -- system over having at least one element. To use a 'Set' though we'd+    -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)+    -- and we'd rather not make users mess with 'OrdValue'.+    deriving (Eq, Show)  instance FromJSON EnumVal where-  parseJSON v = checkUnique . _unNonEmpty' =<< parseJSON v-    where-      checkUnique :: NonEmpty Value -> Parser EnumVal-      checkUnique a-        | allUniqueValues' a = pure (EnumVal a)-        | otherwise = fail "All elements of the Enum validator must be unique."+    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 . NonEmpty' . _unEnumVal+    toJSON = toJSON . UT.NonEmpty' . _unEnumVal  instance Arbitrary EnumVal where-  arbitrary = do-    xs <- traverse (const arbitraryValue) =<< (arbitrary :: Gen [()])-    case N.nonEmpty (toUnique xs) of-      Nothing -> EnumVal . pure <$> arbitraryValue-      Just ne -> pure (EnumVal ne)-    where-      toUnique :: [Value] -> [Value]-      toUnique = fmap _unOrdValue . S.toList . S.fromList . fmap OrdValue+    arbitrary = do+        xs <- traverse (const UT.arbitraryValue) =<< (arbitrary :: Gen [()])+        case NE.nonEmpty (toUnique xs) of+            Nothing -> EnumVal . pure <$> UT.arbitraryValue+            Just ne -> pure (EnumVal ne)+      where+        toUnique :: [Value] -> [Value]+        toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue -enumVal :: EnumVal -> Value -> Maybe (Failure ())+enumVal :: EnumVal -> Value -> Maybe (Fail ()) enumVal (EnumVal vs) x-  | not (allUniqueValues' vs) = Nothing-  | x `elem` vs               = Nothing-  | otherwise                 =-    Just $ Invalid () (toJSON (NonEmpty' vs)) mempty+    | not (UT.allUniqueValues' vs) = Nothing+    | x `elem` vs                  = Nothing+    | otherwise                    = Just $ Failure () (toJSON (UT.NonEmpty' vs))+                                                    mempty x  -------------------------------------------------- -- * type --------------------------------------------------  data TypeVal-  = TypeValString Text-  | TypeValArray (Set Text)-  deriving (Eq, Show)+    = TypeValString Text+    | TypeValArray (Set Text)+    deriving (Eq, Show)  instance FromJSON TypeVal where-  parseJSON v = fmap TypeValString (parseJSON v)-            <|> fmap TypeValArray (parseJSON v)+    parseJSON v = fmap TypeValString (parseJSON v)+              <|> fmap TypeValArray (parseJSON v)  instance ToJSON TypeVal where-  toJSON (TypeValString t) = toJSON t-  toJSON (TypeValArray ts) = toJSON ts+    toJSON (TypeValString t) = toJSON t+    toJSON (TypeValArray ts) = toJSON ts  instance Arbitrary TypeVal where-  arbitrary = oneof [ TypeValString <$> arbitraryText-                    , TypeValArray <$> arbitrarySetOfText-                    ]+    arbitrary = oneof [ TypeValString <$> UT.arbitraryText+                      , TypeValArray <$> UT.arbitrarySetOfText+                      ] -typeVal :: TypeVal -> Value -> Maybe (Failure ())-typeVal (TypeValString t) x = isJsonType x (S.singleton t)-typeVal (TypeValArray ts) x = isJsonType x ts+setFromTypeVal :: TypeVal -> Set Text+setFromTypeVal (TypeValString t) = S.singleton t+setFromTypeVal (TypeValArray ts) = ts -isJsonType :: Value -> Set Text -> Maybe (Failure ())-isJsonType x ts-  | S.null (S.intersection okTypes ts) = Just (Invalid () (toJSON ts) mempty)-  | otherwise                          = Nothing+typeVal :: TypeVal -> Value -> Maybe (Fail ())+typeVal tv x+    | S.null matches = Just (Failure () (toJSON tv) mempty x)+    | otherwise      = Nothing   where+    -- There can be more than one match because a 'Value' can be both a+    -- @"number"@ and an @"integer"@.+    matches :: Set Text+    matches = S.intersection okTypes (setFromTypeVal tv)+     okTypes :: Set Text     okTypes =-      case x of-        Null       -> S.singleton "null"-        (Array _)  -> S.singleton "array"-        (Bool _)   -> S.singleton "boolean"-        (Object _) -> S.singleton "object"-        (String _) -> S.singleton "string"-        (Number y) ->-          case toBoundedInteger y :: Maybe Int of-            Nothing -> S.singleton "number"-            Just _  -> S.fromList ["number", "integer"]+        case x of+            Null       -> S.singleton "null"+            (Array _)  -> S.singleton "array"+            (Bool _)   -> S.singleton "boolean"+            (Object _) -> S.singleton "object"+            (String _) -> S.singleton "string"+            (Number y) ->+                if SCI.isInteger y+                    then S.fromList ["number", "integer"]+                    else S.singleton "number"  ----------------------------------------------------- * other+-- * allOf --------------------------------------------------  allOf-  :: (schema -> Value -> [Failure err])-  -> NonEmpty schema-  -> Value-  -> [Failure err]-allOf f subSchemas x = N.toList subSchemas >>= flip f x+    :: (schema -> Value -> [Fail err])+    -> NonEmpty schema+    -> Value+    -> [Fail err]+allOf f subSchemas x = NE.toList subSchemas >>= flip f x +--------------------------------------------------+-- * anyOf+--------------------------------------------------+ anyOf-  :: ToJSON schema-  => (schema -> Value -> [Failure err])-  -> NonEmpty schema-  -> Value-  -> Maybe (Failure ())+    :: ToJSON schema+    => (schema -> Value -> [Fail err])+    -> NonEmpty schema+    -> Value+    -> Maybe (Fail ()) anyOf f subSchemas x-  | any null (flip f x <$> subSchemas) = Nothing-  | otherwise = Just $ Invalid () (toJSON (NonEmpty' subSchemas)) mempty+    | any null (flip f x <$> subSchemas) = Nothing+    | otherwise = Just $ Failure () (toJSON (UT.NonEmpty' subSchemas))+                                 mempty x +--------------------------------------------------+-- * oneOf+--------------------------------------------------+ oneOf-  :: forall err schema. ToJSON schema-  => (schema -> Value -> [Failure err])-  -> NonEmpty schema-  -> Value-  -> Maybe (Failure ())+    :: forall err schema. ToJSON schema+    => (schema -> Value -> [Fail err])+    -> NonEmpty schema+    -> Value+    -> Maybe (Fail ()) oneOf f subSchemas x-  | length successes == 1 = Nothing-  | otherwise             = Just $ Invalid ()-                                           (toJSON (NonEmpty' subSchemas))-                                           mempty+    | length successes == 1 = Nothing+    | otherwise = Just $ Failure () (toJSON (UT.NonEmpty' subSchemas)) mempty x   where-    successes :: [[Failure err]]-    successes = filter null $ flip f x <$> N.toList subSchemas+    successes :: [[Fail err]]+    successes = filter null $ flip f x <$> NE.toList subSchemas +--------------------------------------------------+-- * not+--------------------------------------------------+ notVal-  :: ToJSON schema-  => (schema -> Value -> [Failure err])-  -> schema-  -> Value-  -> Maybe (Failure ())+    :: ToJSON schema+    => (schema -> Value -> [Fail err])+    -> schema+    -> Value+    -> Maybe (Fail ()) notVal f schema x =-  case f schema x of-    [] -> Just (Invalid () (toJSON schema) mempty)-    _  -> Nothing+    case f schema x of+        [] -> Just (Failure () (toJSON schema) mempty x)+        _  -> Nothing

@@ -1,168 +1,184 @@  module Data.Validator.Draft4.Array where +import           Import+import           Prelude+ import           Control.Monad-import qualified Data.Aeson.Pointer     as P+import qualified Data.Aeson.Pointer     as AP import qualified Data.Text              as T import qualified Data.Vector            as V import           Text.Read              (readMaybe) -import           Data.Validator.Failure+import           Data.Validator.Failure (Fail(..), prependToPath) import           Data.Validator.Utils   (allUniqueValues)-import           Import --- | The spec requires "maxItems" to be non-negative.-maxItems :: Int -> Vector Value -> Maybe (Failure ())+--------------------------------------------------+-- * maxItems+--------------------------------------------------++-- | The spec requires @"maxItems"@ to be non-negative.+maxItems :: Int -> Vector Value -> Maybe (Fail ()) maxItems n xs-  | n < 0           = Nothing-  | V.length xs > n = Just (Invalid () (toJSON n) mempty)-  | otherwise       = Nothing+    | n < 0           = Nothing+    | V.length xs > n = Just (Failure () (toJSON n) mempty (Array xs))+    | otherwise       = Nothing --- | The spec requires "minItems" to be non-negative.-minItems :: Int -> Vector Value -> Maybe (Failure ())+--------------------------------------------------+-- * minItems+--------------------------------------------------++-- | The spec requires @"minItems"@ to be non-negative.+minItems :: Int -> Vector Value -> Maybe (Fail ()) minItems n xs-  | n < 0           = Nothing-  | V.length xs < n = Just (Invalid () (toJSON n) mempty)-  | otherwise       = Nothing+    | n < 0           = Nothing+    | V.length xs < n = Just (Failure () (toJSON n) mempty (Array xs))+    | otherwise       = Nothing -uniqueItems :: Bool -> Vector Value -> Maybe (Failure ())+--------------------------------------------------+-- * uniqueItems+--------------------------------------------------++uniqueItems :: Bool -> Vector Value -> Maybe (Fail ()) uniqueItems True xs-  | allUniqueValues xs = Nothing-  | otherwise          = Just (Invalid () (Bool True) mempty)+   | allUniqueValues xs = Nothing+   | otherwise          = Just (Failure () (Bool True) mempty (Array xs)) uniqueItems False _ = Nothing  -------------------------------------------------- -- * items -------------------------------------------------- -data ItemsInvalid err-  = Items err-  | AdditionalItemsBoolInvalid-  | AdditionalItemsObjectInvalid err-  deriving (Eq, Show)- data Items schema-  = ItemsObject schema-  | ItemsArray [schema]-  deriving (Eq, Show)+    = ItemsObject schema+    | ItemsArray [schema]+    deriving (Eq, Show)  instance FromJSON schema => FromJSON (Items schema) where-  parseJSON v = fmap ItemsObject (parseJSON v)-            <|> fmap ItemsArray (parseJSON v)+    parseJSON v = fmap ItemsObject (parseJSON v)+              <|> fmap ItemsArray (parseJSON v)  instance ToJSON schema => ToJSON (Items schema) where-  toJSON (ItemsObject hm)     = toJSON hm-  toJSON (ItemsArray schemas) = toJSON schemas+    toJSON (ItemsObject hm)     = toJSON hm+    toJSON (ItemsArray schemas) = toJSON schemas  instance Arbitrary schema => Arbitrary (Items schema) where-  arbitrary = oneof [ ItemsObject <$> arbitrary-                    , ItemsArray <$> arbitrary-                    ]+    arbitrary = oneof [ ItemsObject <$> arbitrary+                      , ItemsArray <$> arbitrary+                      ] +data ItemsInvalid err+    = Items err+    | AdditionalItemsBoolInvalid+    | AdditionalItemsObjectInvalid err+    deriving (Eq, Show)+ items-  :: forall err schema.-     (schema -> Value -> [Failure err])-  -> Maybe (AdditionalItems schema)-  -> Items schema-  -> Vector Value-  -> [Failure (ItemsInvalid err)]-items f _ (ItemsObject subSchema) xs = zip [0..] (V.toList xs) >>= g+    :: forall err schema.+       (schema -> Value -> [Fail err])+    -> Maybe (AdditionalItems schema)+    -> Items schema+    -> Vector Value+    -> [Fail (ItemsInvalid err)]+items f _ (ItemsObject subSchema) xs =+    zip [0..] (V.toList xs) >>= g   where-    g :: (Int, Value) -> [Failure (ItemsInvalid err)]-    g (index,x) = modFailure Items-                . addToPath (P.Token (T.pack (show index)))+    g :: (Int, Value) -> [Fail (ItemsInvalid err)]+    g (index,x) = fmap Items+                . prependToPath (AP.Token (T.pack (show index)))               <$> f subSchema x -items f mAdditional (ItemsArray subSchemas) xs = itemFailures-                                              <> additionalItemFailures+items f mAdditional (ItemsArray subSchemas) xs =+    itemFailures <> additionalItemFailures   where     indexedValues :: [(Int, Value)]     indexedValues = zip [0..] (V.toList xs) -    itemFailures :: [Failure (ItemsInvalid err)]+    itemFailures :: [Fail (ItemsInvalid err)]     itemFailures = join (zipWith g subSchemas indexedValues)       where-        g :: schema -> (Int, Value) -> [Failure (ItemsInvalid err)]-        g schema (index,x) = modFailure Items-                           . addToPath (P.Token (T.pack (show index)))+        g :: schema -> (Int, Value) -> [Fail (ItemsInvalid err)]+        g schema (index,x) = fmap Items+                           . prependToPath (AP.Token (T.pack (show index)))                          <$> f schema x -    additionalItemFailures :: [Failure (ItemsInvalid err)]+    additionalItemFailures :: [Fail (ItemsInvalid err)]     additionalItemFailures =-      case mAdditional of-        Nothing  -> mempty-        Just adi -> modFailure correctName-                  . correctIndexes-                <$> additionalItems f adi extras+        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+        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-          :: Failure (AdditionalItemsInvalid err)-          -> Failure (AdditionalItemsInvalid err)-        correctIndexes (Invalid a b c) = Invalid a b (fixIndex c)+          :: Fail (AdditionalItemsInvalid err)+          -> Fail (AdditionalItemsInvalid err)+        correctIndexes (Failure a b c d) = Failure a b (fixIndex c) d           where-            fixIndex :: P.Pointer -> P.Pointer-            fixIndex (P.Pointer (tok:toks)) =-              case readMaybe . T.unpack . P._unToken $ tok of-                Nothing -> P.Pointer $ tok:toks-                Just n  -> P.Pointer $-                  (P.Token . T.pack . show $ n + length subSchemas):toks-            fixIndex (P.Pointer []) = P.Pointer []+            fixIndex :: AP.Pointer -> AP.Pointer+            fixIndex (AP.Pointer (tok:toks)) =+                case readMaybe . T.unpack . AP._unToken $ tok of+                    Nothing -> AP.Pointer $ tok:toks+                    Just n  -> AP.Pointer $+                        (AP.Token . T.pack . show $ n + length subSchemas):toks+            fixIndex (AP.Pointer []) = AP.Pointer []          correctName :: AdditionalItemsInvalid err -> ItemsInvalid err         correctName AdditionalBoolInvalid = AdditionalItemsBoolInvalid         correctName (AdditionalObjectInvalid err) =-          AdditionalItemsObjectInvalid err+            AdditionalItemsObjectInvalid err  -------------------------------------------------- -- * additionalItems -------------------------------------------------- -data AdditionalItemsInvalid err-  = AdditionalBoolInvalid-  | AdditionalObjectInvalid err-  deriving (Eq, Show)- data AdditionalItems schema-  = AdditionalBool Bool-  | AdditionalObject schema-  deriving (Eq, Show)+    = AdditionalBool Bool+    | AdditionalObject schema+    deriving (Eq, Show)  instance FromJSON schema => FromJSON (AdditionalItems schema) where-  parseJSON v = fmap AdditionalBool (parseJSON v)-            <|> fmap AdditionalObject (parseJSON v)+    parseJSON v = fmap AdditionalBool (parseJSON v)+              <|> fmap AdditionalObject (parseJSON v)  instance ToJSON schema => ToJSON (AdditionalItems schema) where-  toJSON (AdditionalBool b)    = toJSON b-  toJSON (AdditionalObject hm) = toJSON hm+    toJSON (AdditionalBool b)    = toJSON b+    toJSON (AdditionalObject hm) = toJSON hm  instance Arbitrary schema => Arbitrary (AdditionalItems schema) where-  arbitrary = oneof [ AdditionalBool <$> arbitrary-                    , AdditionalObject <$> arbitrary-                    ]+    arbitrary = oneof [ AdditionalBool <$> arbitrary+                      , AdditionalObject <$> arbitrary+                      ] +data AdditionalItemsInvalid err+    = AdditionalBoolInvalid+    | AdditionalObjectInvalid err+    deriving (Eq, Show)+ additionalItems-  :: forall err schema.-     (schema -> Value -> [Failure err])-  -> AdditionalItems schema-  -> Vector Value-  -> [Failure (AdditionalItemsInvalid err)]+    :: forall err schema.+       (schema -> Value -> [Fail err])+    -> AdditionalItems schema+    -> Vector Value+    -> [Fail (AdditionalItemsInvalid err)] additionalItems _ (AdditionalBool b) xs-  | b               = mempty-  | V.length xs > 0 = pure (Invalid AdditionalBoolInvalid (Bool b) mempty)-  | otherwise       = mempty+    | 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+    zip [0..] (V.toList xs) >>= g   where-    g :: (Int, Value) -> [Failure (AdditionalItemsInvalid err)]-    g (index,x) = modFailure AdditionalObjectInvalid-                . addToPath (P.Token (T.pack (show index)))+    g :: (Int, Value) -> [Fail (AdditionalItemsInvalid err)]+    g (index,x) = fmap AdditionalObjectInvalid+                . prependToPath (AP.Token (T.pack (show index)))               <$> f subSchema x

@@ -1,51 +1,65 @@  module Data.Validator.Draft4.Number where +import           Import+import           Prelude+ import           Data.Fixed             (mod')-import           Data.Scientific+import           Data.Scientific        (Scientific) -import           Data.Validator.Failure-import           Import+import           Data.Validator.Failure (Fail(..)) --- | The spec requires "multipleOf" to be positive.-multipleOf :: Scientific -> Scientific -> Maybe (Failure ())+--------------------------------------------------+-- * multipleOf+--------------------------------------------------++-- | The spec requires @"multipleOf"@ to be positive.+multipleOf :: Scientific -> Scientific -> Maybe (Fail ()) multipleOf n x-  | n <= 0          = Nothing-  | x `mod'` n /= 0 = Just (Invalid () (toJSON n) mempty)-  | otherwise       = Nothing+    | n <= 0          = Nothing+    | x `mod'` n /= 0 = Just (Failure () (toJSON n) mempty (Number x))+    | otherwise       = Nothing +--------------------------------------------------+-- * maximum+--------------------------------------------------+ data MaximumInvalid-  = Maximum-  | ExclusiveMaximum-  deriving (Eq, Show)+    = Maximum+    | ExclusiveMaximum+    deriving (Eq, Show)  maximumVal-  :: Bool-  -> Scientific-  -> Scientific-  -> Maybe (Failure MaximumInvalid)-maximumVal exclusiveMaximum n x-  | x `greaterThan` n = Just (Invalid err (toJSON n) mempty)-  | otherwise         = Nothing+    :: Bool+    -> Scientific+    -> Scientific+    -> Maybe (Fail MaximumInvalid)+maximumVal exclusive n x+    | x `greaterThan` n = Just (Failure err (toJSON n) mempty (Number x))+    | otherwise         = Nothing   where-    (greaterThan, err) = if exclusiveMaximum-                           then ((>=), ExclusiveMaximum)-                           else ((>), Maximum)+    (greaterThan, err) = if exclusive+                             then ((>=), ExclusiveMaximum)+                             else ((>), Maximum) +--------------------------------------------------+-- * minimum+--------------------------------------------------+ data MinimumInvalid-  = Minimum-  | ExclusiveMinimum-  deriving (Eq, Show)+    = Minimum+    | ExclusiveMinimum+    deriving (Eq, Show)  minimumVal-  :: Bool-  -> Scientific-  -> Scientific-  -> Maybe (Failure MinimumInvalid)-minimumVal exclusiveMinimum n x-  | x `lessThan` n = Just (Invalid err (toJSON n) mempty)-  | otherwise      = Nothing+    :: Bool+    -> Scientific+    -> Scientific+    -> Maybe (Fail MinimumInvalid)+minimumVal exclusive n x+    | x `lessThan` n = Just (Failure err (toJSON n) mempty (Number x))+    | otherwise      = Nothing   where-    (lessThan, err) = if exclusiveMinimum-                        then ((<=), ExclusiveMinimum)-                        else ((<), Minimum)+    (lessThan, err) = if exclusive+                          then ((<=), ExclusiveMinimum)+                          else ((<), Minimum)

@@ -1,11 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}  module Data.Validator.Draft4.Object   ( module Data.Validator.Draft4.Object   , module Data.Validator.Draft4.Object.Properties   ) where +import           Import+-- Hiding is for GHCs before 7.10:+import           Prelude                                 hiding (all, concat,+                                                          foldl)+ import           Data.Aeson.Types                        (Parser) import qualified Data.HashMap.Strict                     as H import           Data.Set                                (Set)@@ -13,27 +17,30 @@ import qualified Data.Text                               as T  import           Data.Validator.Draft4.Object.Properties-import           Data.Validator.Failure+import           Data.Validator.Failure                  (Fail(..)) import           Data.Validator.Utils-import           Import --- For GHCs before 7.10:-import           Prelude                                 hiding (all, concat,-                                                          foldl)+--------------------------------------------------+-- * maxProperties+-------------------------------------------------- --- | The spec requires "maxProperties" to be non-negative.-maxProperties :: Int -> HashMap Text Value -> Maybe (Failure ())+-- | 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 (Invalid () (toJSON n) mempty)-  | otherwise    = Nothing+    | n < 0        = Nothing+    | H.size x > n = Just (Failure () (toJSON n) mempty (Object x))+    | otherwise    = Nothing --- | The spec requires "minProperties" to be non-negative.-minProperties :: Int -> HashMap Text Value -> Maybe (Failure ())+--------------------------------------------------+-- * minProperties+--------------------------------------------------++-- | The spec requires @"minProperties"@ to be non-negative.+minProperties :: Int -> HashMap Text Value -> Maybe (Fail ()) minProperties n x-  | n < 0        = Nothing-  | H.size x < n = Just (Invalid () (toJSON n) mempty)-  | otherwise    = Nothing+    | n < 0        = Nothing+    | H.size x < n = Just (Failure () (toJSON n) mempty (Object x))+    | otherwise    = Nothing  -------------------------------------------------- -- * required@@ -48,39 +55,40 @@ -- 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)+    = Required { _unRequired :: Set Text }+    deriving (Eq, Show, ToJSON)  instance FromJSON Required where-  parseJSON v = checkUnique =<< checkSize =<< parseJSON v-    where-      checkSize :: [Text] -> Parser [Text]-      checkSize a-        | null a    = fail "Required validator must not be empty."-        | otherwise = pure a+    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."+        checkUnique :: [Text] -> Parser Required+        checkUnique a =+            let b = S.fromList a+            -- NOTE: Can use length instead of S.size in GHC 7.10 or later.+            in if length a == S.size b+                then pure (Required b)+                else fail "All elements of the Required validator must be unique."  instance Arbitrary Required where-  arbitrary = do-    x  <- arbitraryText -- Guarantee at least one element.-    xs <- (fmap.fmap) T.pack arbitrary-    pure . Required . S.fromList $ x:xs+    arbitrary = do+        x  <- arbitraryText -- Guarantee at least one element.+        xs <- (fmap.fmap) T.pack arbitrary+        pure . Required . S.fromList $ x:xs -required :: Required -> HashMap Text Value -> Maybe (Failure ())+required :: Required -> HashMap Text Value -> Maybe (Fail ()) required (Required ts) x-  -- NOTE: When we no longer need to support GHCs before 7.10-  -- we can use null from Prelude throughout the library-  -- instead of specialized versions.-  | S.null ts                  = Nothing-  | H.null (H.difference hm x) = Nothing-  | otherwise                  = Just (Invalid () (toJSON ts) mempty)+    -- NOTE: When we no longer need to support GHCs before 7.10+    -- we can use null from Prelude throughout the library+    -- instead of specialized versions.+    | S.null ts                  = Nothing+    | H.null (H.difference hm x) = Nothing+    | otherwise                  = Just (Failure () (toJSON ts)+                                                 mempty (Object x))   where     hm :: HashMap Text Bool     hm = foldl (\b a -> H.insert a True b) mempty ts@@ -89,29 +97,29 @@ -- * dependencies -------------------------------------------------- -data DependencyInvalid err-  = SchemaDependencyInvalid err-  | PropertyDependencyInvalid-  deriving (Eq, Show)- data Dependency schema-  = SchemaDependency schema-  | PropertyDependency (Set Text)-  deriving (Eq, Show)+    = SchemaDependency schema+    | PropertyDependency (Set Text)+    deriving (Eq, Show)  instance FromJSON schema => FromJSON (Dependency schema) where-  parseJSON v = fmap SchemaDependency (parseJSON v)-            <|> fmap PropertyDependency (parseJSON v)+    parseJSON v = fmap SchemaDependency (parseJSON v)+              <|> fmap PropertyDependency (parseJSON v)  instance ToJSON schema => ToJSON (Dependency schema) where-  toJSON (SchemaDependency schema) = toJSON schema-  toJSON (PropertyDependency ts)   = toJSON ts+    toJSON (SchemaDependency schema) = toJSON schema+    toJSON (PropertyDependency ts)   = toJSON ts  instance Arbitrary schema => Arbitrary (Dependency schema) where-  arbitrary = oneof [ SchemaDependency <$> arbitrary-                    , PropertyDependency <$> arbitrarySetOfText-                    ]+    arbitrary = oneof [ SchemaDependency <$> arbitrary+                      , PropertyDependency <$> arbitrarySetOfText+                      ] +data DependencyInvalid err+    = SchemaDependencyInvalid err+    | PropertyDependencyInvalid+    deriving (Eq, Show)+ -- | From the spec: -- <http://json-schema.org/latest/json-schema-validation.html#anchor70> --@@ -125,23 +133,25 @@ -- > Each element MUST be a string, and elements in the array MUST be unique. -- > This is called a property dependency. dependencies-  :: forall err schema. (schema -> Value -> [Failure err])-  -> HashMap Text (Dependency schema)-  -> HashMap Text Value-  -> [Failure (DependencyInvalid err)]+    :: forall err schema.+       (schema -> Value -> [Fail err])+    -> HashMap Text (Dependency schema)+    -> HashMap Text Value+    -> [Fail (DependencyInvalid err)] dependencies f hm x = concat . fmap (uncurry g) . H.toList $ hm   where-    g :: Text -> Dependency schema -> [Failure (DependencyInvalid err)]+    g :: Text -> Dependency schema -> [Fail (DependencyInvalid err)]     g k (SchemaDependency schema)-      | H.member k x =-        modFailure SchemaDependencyInvalid <$> f schema (Object x)-      | otherwise    = mempty+        | H.member k x =+            fmap SchemaDependencyInvalid <$> f schema (Object x)+        | otherwise    = mempty     g k (PropertyDependency ts)-      | H.member k x && not allPresent =-        pure $ Invalid PropertyDependencyInvalid-                       (toJSON (H.singleton k ts))-                       mempty-      | otherwise = mempty+        | 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

@@ -1,190 +1,214 @@-{-# LANGUAGE ScopedTypeVariables #-}  module Data.Validator.Draft4.Object.Properties where +import           Import+import           Prelude+ import           Control.Monad-import           Data.Aeson-import qualified Data.Aeson.Pointer     as P-import qualified Data.HashMap.Strict    as H-import qualified Data.Text              as T+import qualified Data.Aeson.Pointer     as AP+import           Data.Functor           (($>))+import qualified Data.HashMap.Strict    as HM import           Data.Text.Encoding     (encodeUtf8) import qualified Text.Regex.PCRE.Heavy  as RE -import           Data.Validator.Failure-import           Import+import           Data.Validator.Failure (Fail(..), prependToPath) -newtype Remaining = Remaining { _unRemaining :: HashMap Text Value }+-- | For internal use.+newtype Remaining+    = Remaining { _unRemaining :: HashMap Text Value }  -------------------------------------------------- -- * properties --------------------------------------------------  data PropertiesInvalid err-  = PropertiesInvalid err-  | PropPatternInvalid err-  | PropAdditionalInvalid (AdditionalPropertiesInvalid err)-  deriving (Eq, Show)+    = PropertiesInvalid err+    | PropPatternInvalid err+    | PropAdditionalInvalid (AdditionalPropertiesInvalid err)+    deriving (Eq, Show) --- | In order of what's tried: "properties", "patternProperties",--- "additionalProperties".+-- | In order of what's tried: @"properties"@, @"patternProperties"@,+-- @"additionalProperties"@. properties-  :: forall err schema.-     (schema -> Value -> [Failure err])-  -> Maybe (HashMap Text schema)-  -> Maybe (AdditionalProperties schema)-  -> HashMap Text schema-  -> HashMap Text Value-  -> [Failure (PropertiesInvalid err)]+    :: 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 (modFailure PropertiesInvalid) propFailures-  <> fmap (modFailure PropPatternInvalid) patternFailures-  <> fmap (modFailure PropAdditionalInvalid) additionalFailures+       fmap (fmap PropertiesInvalid) propFailures+    <> fmap (fmap PropPatternInvalid) patternFailures+    <> fmap (fmap PropAdditionalInvalid) additionalFailures   where-    propertiesAndUnmatched :: ([Failure err], Remaining)+    propertiesAndUnmatched :: ([Fail err], Remaining)     propertiesAndUnmatched = ( failures-                             , Remaining (H.difference x propertiesHm)+                             , Remaining (HM.difference x propertiesHm)                              )       where-        failures :: [Failure err]-        failures = H.toList (H.intersectionWith f propertiesHm x)-               >>= (\(k,vs) -> fmap (addToPath (P.Token k)) vs)+        failures :: [Fail err]+        failures = HM.toList (HM.intersectionWith f propertiesHm x)+               >>= (\(k,vs) -> fmap (prependToPath (AP.Token k)) vs)      (propFailures, remaining1) = propertiesAndUnmatched -    mPatProp :: Maybe (HashMap Text Value -> ([Failure err], Remaining))+    mPatProp :: Maybe (HashMap Text Value -> ([Fail err], Remaining))     mPatProp = patternAndUnmatched f <$> mPat -    patternFailures :: [Failure err]+    patternFailures :: [Fail err]     patternFailures = case mPatProp of-                        Nothing  -> mempty-                        Just val -> fst (val x)+                          Nothing  -> mempty+                          Just val -> fst (val x)      remaining2 :: Remaining     remaining2 = case mPatProp of-                   Nothing  -> remaining1-                   Just val -> snd . val . _unRemaining $ remaining1+                     Nothing  -> remaining1+                     Just val -> snd . val . _unRemaining $ remaining1 -    additionalFailures :: [Failure (AdditionalPropertiesInvalid err)]-    additionalFailures = case additionalProperties f <$> mAdd of-                           Nothing  -> mempty-                           Just val -> val (_unRemaining remaining2)+    additionalFailures :: [Fail (AdditionalPropertiesInvalid err)]+    additionalFailures =+        case mAdd of+            Nothing -> mempty+            Just a  -> additionalProperties f True a (_unRemaining remaining2)  -------------------------------------------------- -- * patternProperties --------------------------------------------------  data PatternPropertiesInvalid err-  = PPInvalid err-  | PPAdditionalPropertiesInvalid (AdditionalPropertiesInvalid err)-  deriving (Eq, Show)+    = PPInvalid err+    | PPAdditionalPropertiesInvalid (AdditionalPropertiesInvalid err)+    deriving (Eq, Show)  patternProperties-  :: forall err schema.-     (schema -> Value -> [Failure err])-  -> Maybe (AdditionalProperties schema)-  -> HashMap Text schema-  -> HashMap Text Value-  -> [Failure (PatternPropertiesInvalid err)]-patternProperties f mAdd patternPropertiesHm x =-     fmap (modFailure PPInvalid) ppFailures-  <> fmap (modFailure PPAdditionalPropertiesInvalid) addFailures+    :: forall err schema.+       (schema -> Value -> [Fail err])+    -> Bool+    -> Maybe (AdditionalProperties schema)+    -> HashMap Text schema+    -> HashMap Text Value+    -> [Fail (PatternPropertiesInvalid err)]+patternProperties _ False _ _ _ = mempty+patternProperties f _ mAdd patternPropertiesHm x =+       (fmap PPInvalid <$> ppFailures)+    <> (fmap PPAdditionalPropertiesInvalid <$> addFailures)   where-    patternProps :: ([Failure err], Remaining)+    patternProps :: ([Fail err], Remaining)     patternProps = patternAndUnmatched f patternPropertiesHm x      (ppFailures, remaining) = patternProps -    addFailures :: [Failure (AdditionalPropertiesInvalid err)]-    addFailures = case additionalProperties f <$> mAdd of-                    Nothing  -> mempty-                    Just val -> val (_unRemaining remaining)+    addFailures :: [Fail (AdditionalPropertiesInvalid err)]+    addFailures =+        case mAdd of+            Nothing -> mempty+            Just a  -> additionalProperties f True a (_unRemaining remaining)  patternAndUnmatched-  :: forall err schema.-     (schema -> Value -> [Failure err])-  -> HashMap Text schema-  -> HashMap Text Value-  -> ([Failure err], Remaining)+    :: forall err schema.+       (schema -> Value -> [Fail err])+    -> HashMap Text schema+    -> HashMap Text Value+    -> ([Fail err], Remaining) patternAndUnmatched f patPropertiesHm x =-  (H.foldlWithKey' runVals mempty perhapsMatches, remaining)+    (HM.foldlWithKey' runVals mempty perhapsMatches, remaining)   where     perhapsMatches :: HashMap Text (Value, [schema])-    perhapsMatches = H.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x+    perhapsMatches = HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x       where         matchingSchemas-          :: HashMap Text schema-          -> HashMap Text (Value, [schema])-          -> Text-          -> Value-          -> HashMap Text (Value, [schema])+            :: HashMap Text schema+            -> HashMap Text (Value, [schema])+            -> Text+            -> Value+            -> HashMap Text (Value, [schema])         matchingSchemas subSchemas acc k v =-          H.insert k (v, H.foldlWithKey' (checkKey k) mempty subSchemas) acc+            HM.insert k (v, HM.foldlWithKey' (checkKey k) mempty subSchemas) acc          checkKey-          :: Text-          -> [schema]-          -> Text-          -> schema-          -> [schema]+            :: Text+            -> [schema]+            -> Text+            -> schema+            -> [schema]         checkKey k acc r subSchema =-          case RE.compileM (encodeUtf8 r) mempty of-            Left _   -> acc-            Right re -> if k RE.=~ re-                          then pure subSchema <> acc-                          else acc+            case RE.compileM (encodeUtf8 r) mempty of+                Left _   -> acc+                Right re -> if k RE.=~ re+                                then pure subSchema <> acc+                                else acc      runVals-      :: [Failure err]-      -> Text-      -> (Value, [schema])-      -> [Failure err]+        :: [Fail err]+        -> Text+        -> (Value, [schema])+        -> [Fail err]     runVals acc k (v,subSchemas) =-      (subSchemas >>= (\schema -> addToPath (P.Token k) <$> f schema v))-      <> acc+        (subSchemas >>= (\schema -> prependToPath (AP.Token k) <$> f schema v))+        <> acc      remaining :: Remaining-    remaining = Remaining . fmap fst . H.filter (null . snd) $ perhapsMatches+    remaining = Remaining . fmap fst . HM.filter (null . snd) $ perhapsMatches  -------------------------------------------------- -- * additionalProperties -------------------------------------------------- -data AdditionalPropertiesInvalid err-  = APBoolInvalid-  | APObjectInvalid err-  deriving (Eq, Show)- data AdditionalProperties schema-  = AdditionalPropertiesBool Bool-  | AdditionalPropertiesObject schema-  deriving (Eq, Show)+    = AdditionalPropertiesBool Bool+    | AdditionalPropertiesObject schema+    deriving (Eq, Show)  instance FromJSON schema => FromJSON (AdditionalProperties schema) where-  parseJSON v = fmap AdditionalPropertiesBool (parseJSON v)-            <|> fmap AdditionalPropertiesObject (parseJSON v)+    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+    toJSON (AdditionalPropertiesBool b)    = toJSON b+    toJSON (AdditionalPropertiesObject hm) = toJSON hm  instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where-  arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary-                    , AdditionalPropertiesObject <$> arbitrary-                    ]+    arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary+                      , AdditionalPropertiesObject <$> arbitrary+                      ] +data AdditionalPropertiesInvalid err+    = APBoolInvalid+    | APObjectInvalid err+    deriving (Eq, Show)+ additionalProperties-  :: forall err schema.-     (schema -> Value -> [Failure err])-  -> AdditionalProperties schema-  -> HashMap Text Value-  -> [Failure (AdditionalPropertiesInvalid err)]-additionalProperties _ (AdditionalPropertiesBool False) x-  | H.size x > 0 = pure $ Invalid APBoolInvalid (Bool False) mempty-  | otherwise    = mempty-additionalProperties _ (AdditionalPropertiesBool True) _ = mempty-additionalProperties f (AdditionalPropertiesObject schema) x = H.toList x >>= g+    :: forall err schema.+       (schema -> Value -> [Fail err])+    -> Bool+    -> AdditionalProperties schema+    -> HashMap Text Value+    -> [Fail (AdditionalPropertiesInvalid err)]+additionalProperties _ False _ _ = mempty+additionalProperties f _ a x =+    case a of+        AdditionalPropertiesBool b ->+            ($> APBoolInvalid) <$> additionalPropertiesBool b x+        AdditionalPropertiesObject b ->+            fmap APObjectInvalid <$> additionalPropertiesObject f b x++additionalPropertiesBool+    :: Bool+    -> HashMap Text Value+    -> [Fail ()]+additionalPropertiesBool False x+    | HM.size x > 0 = pure $ Failure () (Bool False) mempty (Object x)+    | otherwise    = mempty+additionalPropertiesBool True _ = mempty++additionalPropertiesObject+    :: forall err schema.+       (schema -> Value -> [Fail err])+    -> schema+    -> HashMap Text Value+    -> [Fail err]+additionalPropertiesObject f schema x = HM.toList x >>= g   where-    g :: (Text, Value) -> [Failure (AdditionalPropertiesInvalid err)]-    g (k,v) = modFailure APObjectInvalid-            . addToPath (P.Token k)-          <$> f schema v+    g :: (Text, Value) -> [Fail err]+    g (k,v) = prependToPath (AP.Token k) <$> f schema v

@@ -1,32 +1,45 @@  module Data.Validator.Draft4.String where -import           Data.Aeson+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-import           Import+import           Data.Validator.Failure (Fail(..)) --- | The spec requires "maxLength" to be non-negative.-maxLength :: Int -> Text -> Maybe (Failure ())+--------------------------------------------------+-- * maxLength+--------------------------------------------------++-- | The spec requires @"maxLength"@ to be non-negative.+maxLength :: Int -> Text -> Maybe (Fail ()) maxLength n x-  | n <= 0         = Nothing-  | T.length x > n = Just (Invalid () (toJSON n) mempty)-  | otherwise      = Nothing+    | n <= 0         = Nothing+    | T.length x > n = Just (Failure () (toJSON n) mempty (String x))+    | otherwise      = Nothing --- | The spec requires "minLength" to be non-negative.-minLength :: Int -> Text -> Maybe (Failure ())+--------------------------------------------------+-- * minLength+--------------------------------------------------++-- | The spec requires @"minLength"@ to be non-negative.+minLength :: Int -> Text -> Maybe (Fail ()) minLength n x-  | n <= 0         = Nothing-  | T.length x < n = Just (Invalid () (toJSON n) mempty)-  | otherwise      = Nothing+    | n <= 0         = Nothing+    | T.length x < n = Just (Failure () (toJSON n) mempty (String x))+    | otherwise      = Nothing -patternVal :: Text -> Text -> Maybe (Failure ())+--------------------------------------------------+-- * pattern+--------------------------------------------------++patternVal :: Text -> Text -> Maybe (Fail ()) patternVal t x =-  case RE.compileM (encodeUtf8 t) mempty of-    Left _   -> Just (Invalid () (toJSON t) mempty)-    Right re -> if x RE.=~ re-                  then Nothing-                  else Just (Invalid () (toJSON t) mempty)+    case RE.compileM (encodeUtf8 t) mempty of+        Left _   -> Just (Failure () (toJSON t) mempty (String x))+        Right re -> if x RE.=~ re+                        then Nothing+                        else Just (Failure () (toJSON t) mempty (String x))

@@ -1,42 +1,49 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-}  module Data.Validator.Failure where -import qualified Data.Aeson.Pointer as P- import           Import---- For GHCs before 7.10:+-- 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). ----- Thus validators that can only fail in one way return 'FailureInfo's.--- Validators that can fail in multiple ways return 'ValidationFailure's--- along with an custom error sum type for that particular validator.+-- 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 'ValidationFailure' with+-- The schema's validate function will return a 'Fail' with -- that sum type as its type argument.-data Failure err = Invalid-  { _invalidValidatorsCalled :: !err-  , _invalidFinalValidator   :: !Value-  , _invalidOffendingData    :: !P.Pointer-  } deriving (Eq, Show)--setFailure :: b -> Failure a -> Failure b-setFailure e (Invalid _ a b) = Invalid e a b--modFailure :: (a -> b) -> Failure a -> Failure b-modFailure f v@(Invalid a _ _) = v { _invalidValidatorsCalled = f a }+--+-- 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) -addToPath :: P.Token -> Failure a -> Failure a-addToPath tok v@(Invalid _ _ a) = v { _invalidOffendingData = addToken a }-  where-    addToken :: P.Pointer -> P.Pointer-    addToken (P.Pointer ts) = P.Pointer (ts <> pure tok)+prependToPath :: AP.Token -> Fail a -> Fail a+prependToPath tok failure =+    let old = _failureOffendingPointer failure+    in failure { _failureOffendingPointer = AP.Pointer [tok] <> old }

@@ -1,56 +1,44 @@- -- | JSON Reference is described here: -- <http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03> -- -- And is extended for JSON Schema here: -- <http://json-schema.org/latest/json-schema-core.html#anchor26>------ Notes on where these functions are used:------   * 'Data.JsonSchema.Fetch.includeSubschemas' uses 'updateResolutionScope'.------   * 'Data.JsonSchema.Fetch.foldFunction' uses 'resolveReference'.------   * 'Data.JsonSchema.Draft4.Internal' uses 'updateResolutionScope'---     throughout.------   * 'Data.Validator.Draft4.Any.ref' uses 'resolveReference' and---     'resolveFragment'.  module Data.Validator.Reference where -import qualified Data.Aeson.Pointer     as P+import           Import+import           Prelude++import qualified Data.Aeson.Pointer     as AP import qualified Data.Text              as T-import           Data.Text.Encoding+import           Data.Text.Encoding     (decodeUtf8, encodeUtf8) import           Network.HTTP.Types.URI (urlDecode) import           System.FilePath        ((</>), dropFileName) -import           Import- type URIBase = Maybe Text type URIBaseAndFragment = (Maybe Text, Maybe Text)  updateResolutionScope :: URIBase -> Maybe Text -> URIBase updateResolutionScope mScope idKeyword-  | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t-  | otherwise           = mScope+    | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t+    | otherwise           = mScope  resolveReference :: URIBase -> Text -> URIBaseAndFragment resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t  resolveFragment-  :: (FromJSON schema, ToJSON schema, Show schema)-  => Maybe Text-  -> schema-  -> Maybe schema+    :: (FromJSON schema, ToJSON schema)+    => Maybe Text+    -> schema+    -> Maybe schema resolveFragment Nothing schema        = Just schema resolveFragment (Just pointer) schema = do-  let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer-  p <- either (const Nothing) Just (P.unescape urlDecoded)-  x <- either (const Nothing) Just (P.resolve p (toJSON schema))-  case fromJSON x of-    Error _         -> Nothing-    Success schema' -> Just schema'+    let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer+    p <- either (const Nothing) Just (AP.unescape urlDecoded)+    x <- either (const Nothing) Just (AP.resolve p (toJSON schema))+    case fromJSON x of+        Error _         -> Nothing+        Success schema' -> Just schema'  -------------------------------------------------- -- * Helpers@@ -73,19 +61,19 @@ resolveScopeAgainst :: Maybe Text -> Text -> Text resolveScopeAgainst Nothing t = t resolveScopeAgainst (Just scope) t-  | isRemoteReference t = t-  | otherwise           = smartAppend+    | isRemoteReference t = t+    | otherwise           = smartAppend   where     -- There shouldn't be a fragment at the end of a scope URI,     -- but just in case a user leaves one in we want to be sure     -- to cut it off before appending.     smartAppend :: Text     smartAppend =-      case baseAndFragment scope of-        (Just base,_) ->-          case T.unpack t of-            -- We want "/foo" and "#/bar" to combine into-            -- "/foo#/bar" not "/foo/#/bar".-            '#':_ -> base <> t-            _     -> T.pack (dropFileName (T.unpack base) </> T.unpack t)-        _ -> t+        case baseAndFragment scope of+            (Just base,_) ->+                case T.unpack t of+                    -- We want "/foo" and "#/bar" to combine into+                    -- "/foo#/bar" not "/foo/#/bar".+                    '#':_ -> base <> t+                    _     -> T.pack (dropFileName (T.unpack base) </> T.unpack t)+            _ -> t

@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveFunctor #-}++module Data.Validator.Types where++import           Prelude++import           Data.Aeson             (Value)+import           Data.Profunctor        (Profunctor(..))++import           Data.Validator.Failure (Fail)++data Validator schema val err = Validator+    { _embedded :: val -> ([schema], [schema])+      -- ^ The first list is embedded schemas that validate the same piece+      -- of data this schema validates (such as schemas embedded in 'allOf').+      -- The second is embedded schemas that validate a subset of that data+      -- (such as the schemas embedded in 'items').+      --+      -- This is done to allow static detection of loops, though this isn't+      -- implemented yet (though the Draft4 code does do live loop detection+      -- during validation).+    , _validate :: val -> Value -> [Fail err]+    } deriving Functor++instance Profunctor (Validator schema) where+    lmap f (Validator a b) = Validator (lmap f a) (lmap f b)+    rmap = fmap

@@ -1,18 +1,19 @@  module Data.Validator.Utils where +import           Import+import           Prelude+ import           Control.Arrow-import qualified Data.HashMap.Strict  as H+import qualified Data.HashMap.Strict  as HM import           Data.List.NonEmpty   (NonEmpty)-import qualified Data.List.NonEmpty   as N+import qualified Data.List.NonEmpty   as NE import           Data.Scientific      (Scientific, fromFloatDigits) import           Data.Set             (Set) import qualified Data.Set             as S import qualified Data.Text            as T import qualified Data.Vector          as V -import           Import- -------------------------------------------------- -- * QuickCheck --------------------------------------------------@@ -36,7 +37,7 @@         | otherwise = oneof $             fmap (Array . V.fromList) (traverse (const (f (n `div` 10)))               =<< (arbitrary :: Gen [()]))-          : fmap (Object . H.fromList) (traverse (const (g (n `div` 10)))+          : fmap (Object . HM.fromList) (traverse (const (g (n `div` 10)))               =<< (arbitrary :: Gen [()]))           : nonRecursive @@ -45,14 +46,14 @@      nonRecursive :: [Gen Value]     nonRecursive =-      [ pure Null-      , Bool <$> arbitrary-      , String <$> arbitraryText-      , Number <$> arbitraryScientific-      ]+        [ pure Null+        , Bool <$> arbitrary+        , String <$> arbitraryText+        , Number <$> arbitraryScientific+        ]  arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a)-arbitraryHashMap = H.fromList . fmap (first T.pack) <$> arbitrary+arbitraryHashMap = HM.fromList . fmap (first T.pack) <$> arbitrary  arbitrarySetOfText :: Gen (Set Text) arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary@@ -60,21 +61,21 @@ newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a }  instance FromJSON a => FromJSON (NonEmpty' a) where-  parseJSON v = do-    xs <- parseJSON v-    case N.nonEmpty xs of-      Nothing -> fail "Must have at least one item."-      Just ne -> pure (NonEmpty' ne)+    parseJSON v = do+        xs <- parseJSON v+        case NE.nonEmpty xs of+            Nothing -> fail "Must have at least one item."+            Just ne -> pure (NonEmpty' ne)  instance ToJSON a => ToJSON (NonEmpty' a) where-  toJSON = toJSON . N.toList . _unNonEmpty'+    toJSON = toJSON . NE.toList . _unNonEmpty'  instance Arbitrary a => Arbitrary (NonEmpty' a) where-  arbitrary = do-    xs <- arbitrary-    case N.nonEmpty xs of-      Nothing -> NonEmpty' . pure <$> arbitrary-      Just ne -> pure (NonEmpty' ne)+    arbitrary = do+        xs <- arbitrary+        case NE.nonEmpty xs of+            Nothing -> NonEmpty' . pure <$> arbitrary+            Just ne -> pure (NonEmpty' ne)  -------------------------------------------------- -- * allUniqueValues@@ -86,7 +87,7 @@ -- NOTE: When we no longer support GHC 7.8 we can generalize -- allUnique to work on any Foldable and remove this function. allUniqueValues' :: NonEmpty Value -> Bool-allUniqueValues' = allUnique . fmap OrdValue . N.toList+allUniqueValues' = allUnique . fmap OrdValue . NE.toList  allUnique :: (Ord a) => [a] -> Bool allUnique xs = S.size (S.fromList xs) == length xs@@ -97,26 +98,36 @@ newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq  instance Ord OrdValue where-  (OrdValue Null) `compare` (OrdValue Null) = EQ-  (OrdValue Null) `compare` _               = LT-  _               `compare` (OrdValue Null) = GT+    (OrdValue Null) `compare` (OrdValue Null) = EQ+    (OrdValue Null) `compare` _               = LT+    _               `compare` (OrdValue Null) = GT -  (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y-  (OrdValue (Bool _)) `compare` _                   = LT-  _                   `compare` (OrdValue (Bool _)) = GT+    (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y+    (OrdValue (Bool _)) `compare` _                   = LT+    _                   `compare` (OrdValue (Bool _)) = GT -  (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y-  (OrdValue (Number _)) `compare` _                     = LT-  _                     `compare` (OrdValue (Number _)) = GT+    (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y+    (OrdValue (Number _)) `compare` _                     = LT+    _                     `compare` (OrdValue (Number _)) = GT -  (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y-  (OrdValue (String _)) `compare` _                     = LT-  _                     `compare` (OrdValue (String _)) = GT+    (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y+    (OrdValue (String _)) `compare` _                     = LT+    _                     `compare` (OrdValue (String _)) = GT -  (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) =-    (OrdValue <$> xs) `compare` (OrdValue <$> ys)-  (OrdValue (Array _))  `compare` _                     = LT-  _                     `compare` (OrdValue (Array _))  = GT+    (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) =+        (OrdValue <$> xs) `compare` (OrdValue <$> ys)+    (OrdValue (Array _))  `compare` _                     = LT+    _                     `compare` (OrdValue (Array _))  = GT -  (OrdValue (Object x)) `compare` (OrdValue (Object y)) =-    H.toList (OrdValue <$> x) `compare` H.toList (OrdValue <$> y)+    (OrdValue (Object x)) `compare` (OrdValue (Object y)) =+        HM.toList (OrdValue <$> x) `compare` HM.toList (OrdValue <$> y)++--------------------------------------------------+-- * other+--------------------------------------------------++fromJSONEither :: FromJSON a => Value -> Either Text a+fromJSONEither a =+    case fromJSON a of+        Error e   -> Left (T.pack e)+        Success b -> Right b

@@ -4,51 +4,119 @@ import           Control.Applicative import           Control.Monad          (unless) import           Data.Aeson-import           Data.List              (isSuffixOf)+import           Data.Foldable          (traverse_)+import qualified Data.List.NonEmpty     as N import           Data.Monoid-import           System.Directory       (getDirectoryContents)+import qualified System.Timeout         as TO import           Test.Tasty             (TestTree, defaultMain, testGroup) import qualified Test.Tasty.HUnit       as HU import           Test.Tasty.QuickCheck  (testProperty) +import qualified Data.JsonSchema.Draft4 as D4+import           Data.JsonSchema.Fetch  (ReferencedSchemas(..))+import qualified Data.JsonSchema.Types  as JT+import           Local.Failure          (correctPaths)+import           Local.Validation       (fetchFromFilesystem,+                                         generalValidation)+import           Local.Reference        (referenceTests)+import           Shared+ -- Examples-import qualified CustomSchema+import qualified AlternateSchema import qualified Full-import qualified PrettyShowFailure import qualified Simple -import           Data.JsonSchema.Draft4-import           Local.Failure          (correctPaths)-import           Local.Filesystem       (fetchFromFilesystem)-import           Local.Reference        (referenceTests)-import           Shared                 (isLocal, readSchemaTests, toTest)- dir :: String dir = "JSON-Schema-Test-Suite/tests/draft4" +supplementDir :: String+supplementDir = "test/supplement"+ main :: IO () main = do-  filenames <- filter isLocal . filter (".json" `isSuffixOf`) <$> getDirectoryContents dir-  ts <- readSchemaTests dir filenames-  defaultMain . testGroup "Tests not requiring an HTTP server" $-      testGroup "Check that examples compile and don't throw errors" exampleTests-    : testGroup "QuickCheck tests" quickCheckTests-    : testGroup "Report the path to invalid data correctly" correctPaths-    : testGroup "Test the referencesViaFilesystem function" fetchFromFilesystem-    : testGroup "Test the Reference module" referenceTests-    : fmap toTest ts +    -- Language agnostic tests+    ts <- readSchemaTests+              dir+              (\a -> not (isHTTPTest a || skipOptional a))++    -- Custom supplements to the language agnostic tests+    supplementTs <- readSchemaTests+                        supplementDir+                        (\a -> not (isHTTPTest a || skipOptional a))++    defaultMain . testGroup "Tests not requiring an HTTP server" $+        [ testGroup+            "Check that examples compile and don't throw errors"+            exampleTests+        , testGroup+            "QuickCheck tests"+            quickCheckTests+        , testGroup+            "Report the path to invalid data correctly"+            correctPaths+        , testGroup+            "Test the Reference module"+            referenceTests+        , testGroup+            "Test the referencesViaFilesystem function"+            fetchFromFilesystem+        , testGroup+            "Supplementary validation tests written in Haskell"+            generalValidation+        , testGroup+            "Supplementary tests written in JSON (using the record based schema)"+            (toTest (fmap timeout . validate) <$> supplementTs)+        , testGroup+            "Supplementary tests written in JSON (using the 'Value' based schema)"+            (toTest (fmap timeout . validateExample) <$> supplementTs)+        , testGroup+            "Language agnostic local tests (using the record based schema)"+            (toTest validate <$> ts)+        , testGroup+            "Language agnostic local tests (using the 'Value' based schema)"+            (toTest validateExample <$> ts)+        ]+  where+    timeout :: HU.Assertion -> HU.Assertion+    timeout f = do+        res <- TO.timeout 3000000 f+        case res of+            Nothing -> HU.assertFailure "timeout expired"+            Just a  -> pure a++    validate :: D4.Schema -> SchemaTestCase -> HU.Assertion+    validate s sc = do+        res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc)+        let failures = case res of+                           Right ()           -> mempty+                           Left (D4.HVData a) -> N.toList a+                           other              -> error ("Local.validate error: "+                                                       <> show other)+        traverse_ (checkPointer (_scData sc)) failures+        assertResult sc failures++    validateExample :: JT.Schema -> SchemaTestCase -> HU.Assertion+    validateExample s sc = do+        res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing)+        case res of+            Left e          -> error ("Local.validateExample error: " <> show e)+            Right schemaMap -> do+                let failures = AlternateSchema.validate+                                   (ReferencedSchemas s schemaMap)+                                   Nothing s (_scData sc)+                traverse_ (checkPointer (_scData sc)) failures+                assertResult sc failures+ quickCheckTests :: [TestTree] quickCheckTests =-  [testProperty "Invert schemas through JSON without change" invertSchema]+    [testProperty "Invert schemas through JSON without change" invertSchema]   where-    invertSchema :: Schema -> Bool+    invertSchema :: D4.Schema -> Bool     invertSchema a = Just a == decode (encode a)  exampleTests :: [TestTree] exampleTests =-  [ HU.testCase "CustomSchema example" CustomSchema.example-  , HU.testCase "Full example" Full.example-  , HU.testCase "PrettyShowFailure example" PrettyShowFailure.example-  , HU.testCase "Simple example" Simple.example-  ]+    [ HU.testCase "Full example" Full.example+    , HU.testCase "Simple example" Simple.example+    ]

@@ -1,55 +1,68 @@  module Local.Failure where +import           Prelude+ import           Data.Aeson-import qualified Data.Aeson.Pointer     as P+import qualified Data.Aeson.Pointer          as P import           Data.Monoid-import           Test.Tasty             (TestTree)-import qualified Test.Tasty.HUnit       as HU+import           Test.Tasty                  (TestTree)+import qualified Test.Tasty.HUnit            as HU  import           Data.JsonSchema.Draft4-import qualified Data.Validator.Draft4  as VA+import           Data.JsonSchema.Draft4.Spec (validate)+import qualified Data.Validator.Draft4.Array as AR  correctPaths :: [TestTree] correctPaths =-  [ HU.testCase "Items object" itemsObject-  , HU.testCase "Items array" itemsArray-  ]+    [ HU.testCase "Items object" itemsObject+    , HU.testCase "Items array" itemsArray+    ]  itemsObject :: IO ()-itemsObject = HU.assertEqual "Path to invalid data"-                             (P.Pointer [P.Token "0"])-                             (_invalidOffendingData failure)+itemsObject =+    HU.assertEqual+        "Path to invalid data"+        [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"])+                 (toJSON [True, True])+        ]+        failures   where-    [failure] = runValidate (ReferencedSchemas schema mempty)-                            sw (toJSON [[True, True]])+    failures = validate (ReferencedSchemas schema mempty)+                        sw (toJSON [[True, True]])      schema :: Schema     schema = emptySchema-      { _schemaItems = Just (VA.ItemsObject (emptySchema { _schemaUniqueItems = Just True }))-      }+        { _schemaItems = Just $ AR.ItemsObject+            (emptySchema { _schemaUniqueItems = Just True })+        }      sw :: SchemaWithURI Schema     sw = SchemaWithURI-      { _swSchema = schema-      , _swURI    = Nothing-      }+        { _swSchema = schema+        , _swURI    = Nothing+        }  itemsArray :: IO ()-itemsArray = HU.assertEqual "Path to invalid data"-                            (P.Pointer [P.Token "0"])-                            (_invalidOffendingData failure)+itemsArray =+    HU.assertEqual+        "Path to invalid data"+        [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"])+                 (toJSON [True, True])+        ]+        failures   where-    [failure] = runValidate (ReferencedSchemas schema mempty)-                            sw (toJSON [[True, True]])+    failures = validate (ReferencedSchemas schema mempty)+                        sw (toJSON [[True, True]])      schema :: Schema     schema = emptySchema-      { _schemaItems = Just (VA.ItemsArray [emptySchema { _schemaUniqueItems = Just True }])-      }+        { _schemaItems = Just $ AR.ItemsArray+            [emptySchema { _schemaUniqueItems = Just True }]+        }      sw :: SchemaWithURI Schema     sw = SchemaWithURI-      { _swSchema = schema-      , _swURI    = Nothing-      }+        { _swSchema = schema+        , _swURI    = Nothing+        }

@@ -1,56 +0,0 @@--module Local.Filesystem where--import           Control.Applicative-import           Data.Aeson-import           Data.Monoid-import           Test.Tasty             (TestTree)-import qualified Test.Tasty.HUnit       as HU-import           Data.Text              (Text)--import           Data.JsonSchema.Draft4--fetchFromFilesystem :: [TestTree]-fetchFromFilesystem =-  [ HU.testCase-      "readFile exceptions are turned into Lefts"-      readFileExceptions--  , HU.testCase-      "Relative reference to local file"-      (resolve "test/Local/schema.json")-  , HU.testCase-      "Chained relative references to local files"-      (resolve "./test/Local/schema-with-ref.json")-  ]--readFileExceptions :: IO ()-readFileExceptions = do-  res <- referencesViaFilesystem (SchemaWithURI schema Nothing)-  case res of-    Left (FSReadFailure _) -> pure ()-    a                      -> error (msg <> show a)-  where-    schema :: Schema-    schema = emptySchema { _schemaRef = Just "does-not-exist.json" }--    msg :: String-    msg = "expected referencesViaFilesystem to return ReadFailure,"-       <> " instead got: "---- * Helpers--resolve :: Text -> IO ()-resolve ref = do-  let schema = emptySchema { _schemaRef = Just ref }-  res <- fetchFilesystemAndValidate (SchemaWithURI schema Nothing) badData-  case res of-    Left (FVData _) -> pure ()-    a               -> error (msg <> show a)-  where-    badData :: Value-    badData = toJSON [True, True]--    msg :: String-    msg = "expected fetchFilesystemAndValidate to return"-       <> " Left (FVData [_]), instead got: "

@@ -8,44 +8,44 @@  referenceTests :: [TestTree] referenceTests =-  [ HU.testCase "updateResolutionScope test cases" updateResolutionScopeTests-  , HU.testCase "resolveReference test cases" resolveReferenceTests-  ]+    [ HU.testCase "updateResolutionScope test cases" updateResolutionScopeTests+    , HU.testCase "resolveReference test cases" resolveReferenceTests+    ]  updateResolutionScopeTests :: IO () updateResolutionScopeTests = do-  HU.assertEqual-    "case 1 result"-    Nothing-    (updateResolutionScope Nothing Nothing)-  HU.assertEqual-    "case 2 result"-    Nothing-    (updateResolutionScope Nothing (Just "#"))-  HU.assertEqual-    "case 3 result"-    (Just "foo")-    (updateResolutionScope Nothing (Just "foo"))-  HU.assertEqual-    "case 4 result"-    (Just "/./bar") -- TODO: Normalize after updateResolutionScope.-    (updateResolutionScope (Just "/foo") (Just "./bar"))+    HU.assertEqual+        "case 1 result"+        Nothing+        (updateResolutionScope Nothing Nothing)+    HU.assertEqual+        "case 2 result"+        Nothing+        (updateResolutionScope Nothing (Just "#"))+    HU.assertEqual+        "case 3 result"+        (Just "foo")+        (updateResolutionScope Nothing (Just "foo"))+    HU.assertEqual+        "case 4 result"+        (Just "/./bar") -- TODO: Normalize after updateResolutionScope.+        (updateResolutionScope (Just "/foo") (Just "./bar"))  resolveReferenceTests :: IO () resolveReferenceTests = do-  HU.assertEqual-    "case 1 result"-    (Just "/bar", Nothing)-    (resolveReference (Just "/foo") "bar")-  HU.assertEqual-    "case 2 result"-    (Just "/baz", Nothing)-    (resolveReference (Just "/foo/bar") "/baz")-  HU.assertEqual-    "case 3 result"-    (Nothing, Just "/bar")-    (resolveReference Nothing "#/bar")-  HU.assertEqual-    "case 4 result"-    (Just "/foo", Just "/bar")-    (resolveReference (Just "/foo") "#/bar")+    HU.assertEqual+        "case 1 result"+        (Just "/bar", Nothing)+        (resolveReference (Just "/foo") "bar")+    HU.assertEqual+        "case 2 result"+        (Just "/baz", Nothing)+        (resolveReference (Just "/foo/bar") "/baz")+    HU.assertEqual+        "case 3 result"+        (Nothing, Just "/bar")+        (resolveReference Nothing "#/bar")+    HU.assertEqual+        "case 4 result"+        (Just "/foo", Just "/bar")+        (resolveReference (Just "/foo") "#/bar")

@@ -0,0 +1,82 @@++module Local.Validation where++import           Control.Applicative+import           Data.Aeson+import qualified Data.Aeson             as AE+import qualified Data.HashMap.Strict    as HM+import           Data.Monoid+import           Data.Text              (Text)+import           Test.Tasty             (TestTree)+import qualified Test.Tasty.HUnit       as HU++import           Data.JsonSchema.Draft4+import qualified Data.JsonSchema.Types  as JT++import qualified AlternateSchema        as AS++fetchFromFilesystem :: [TestTree]+fetchFromFilesystem =+    [ HU.testCase+        "readFile exceptions are turned into Lefts"+        readFileExceptions++    , HU.testCase+        "Relative reference to local file"+        (resolve "test/Local/schema.json")+    , HU.testCase+        "Chained relative references to local files"+        (resolve "./test/Local/schema-with-ref.json")+    ]++readFileExceptions :: IO ()+readFileExceptions = do+    res <- referencesViaFilesystem (SchemaWithURI schema Nothing)+    case res of+        Left (FSReadFailure _) -> pure ()+        a                      -> error (msg <> show a)+  where+    schema :: Schema+    schema = emptySchema { _schemaRef = Just "does-not-exist.json" }++    msg :: String+    msg = "expected referencesViaFilesystem to return ReadFailure,"+       <> " instead got: "++resolve :: Text -> IO ()+resolve ref = do+    let schema = emptySchema { _schemaRef = Just ref }+    res <- fetchFilesystemAndValidate (SchemaWithURI schema Nothing) badData+    case res of+        Left (FVData _) -> pure ()+        a               -> error (msg <> show a)+  where+    badData :: Value+    badData = toJSON [True, True]++    msg :: String+    msg = "expected fetchFilesystemAndValidate to return"+       <> " Left (FVData [_]), instead got: "++-- | Validation tests that were hard to write in JSON for whatever reason.+generalValidation :: [TestTree]+generalValidation =+    [ HU.testCase+        "Don't parse schemas that have Null in a forbidden location"+        forbidNull+    , HU.testCase+        "The 'Value' based Schema's checkSchema should catch Nulls"+        exampleForbidNull+    ]++forbidNull :: IO ()+forbidNull =+    case fromJSON (Object (HM.singleton "type" Null)) of+        AE.Error _   -> pure ()+        AE.Success a -> HU.assertFailure ("parsed to: " <> show (a :: Schema))++exampleForbidNull :: IO ()+exampleForbidNull =+    case AS.checkSchema (JT.Schema (HM.singleton "type" Null)) of+        [] -> HU.assertFailure "No checkSchema failures"+        _  -> pure ()

@@ -2,25 +2,63 @@  import           Control.Applicative import           Control.Concurrent.Async       (withAsync)-import           Data.List                      (isSuffixOf)+import           Data.Foldable                  (traverse_)+import qualified Data.List.NonEmpty             as N+import           Data.Monoid import           Network.Wai.Application.Static (defaultFileServerSettings,                                                  staticApp) import           Network.Wai.Handler.Warp       (run)-import           System.Directory               (getDirectoryContents) import           Test.Tasty                     (defaultMain, testGroup)+import qualified Test.Tasty.HUnit               as HU -import           Shared                         (isLocal, readSchemaTests,-                                                 toTest)+import qualified Data.JsonSchema.Draft4         as D4+import           Data.JsonSchema.Fetch          (ReferencedSchemas(..))+import qualified Data.JsonSchema.Types          as JT+import           Shared +-- Examples+import qualified AlternateSchema+ dir :: String dir = "JSON-Schema-Test-Suite/tests/draft4"  main :: IO () main = withAsync serve $ \_ -> do-  filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)-                 <$> getDirectoryContents dir-  ts <- readSchemaTests dir filenames-  defaultMain . testGroup "Tests that run an HTTP server" $ toTest <$> ts+    ts <- readSchemaTests dir isHTTPTest+    defaultMain . testGroup "Tests that run an HTTP server" $+        [ testGroup+            "Language agnostic remote tests (using the record based schema)"+            (toTest validate <$> ts)+        , testGroup+            "Language agnostic remote tests (using the 'Value' based schema)"+            (toTest validateExample <$> ts)+        ]+  where+    validate :: D4.Schema -> SchemaTestCase -> HU.Assertion+    validate s sc = do+        res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc)+        let failures = case res of+                           Right ()           -> mempty+                           Left (D4.HVData a) -> N.toList a+                           other              -> error ("Local.validate error: "+                                                       <> show other)+        traverse_ (checkPointer (_scData sc)) failures+        assertResult sc failures +    validateExample :: JT.Schema -> SchemaTestCase -> HU.Assertion+    validateExample s sc = do+        res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing)+        case res of+            Left e          -> error ("Remote.validateExample error: " <> show e)+            Right schemaMap -> do+                let failures = AlternateSchema.validate+                                   (ReferencedSchemas s schemaMap)+                                   Nothing s (_scData sc)+                traverse_ (checkPointer (_scData sc)) failures+                assertResult sc failures+ serve :: IO ()-serve = run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes"+serve = run 1234+      . staticApp+      . defaultFileServerSettings+      $ "JSON-Schema-Test-Suite/remotes"

@@ -5,95 +5,165 @@ import           Control.Applicative import           Control.Monad 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           Test.Tasty             (TestTree) import qualified Test.Tasty.HUnit       as HU  import qualified Data.JsonSchema.Draft4 as D4 -isLocal :: String -> Bool-isLocal file = (file /= "definitions.json")-            && (file /= "ref.json")-            && (file /= "refRemote.json")+-- Recursively return the contents of a directory+-- (or return itself if given a file as an argument).+--+-- Return paths are relative to that directory.+listFiles :: FilePath -> IO [FilePath]+listFiles path = fmap ( fromMaybe "stripPrefix failed"+                      . stripPrefix (path <> "/")+                      ) <$> listFilesFullPath path +-- Recursively return the contents of a directory+-- (or return itself if given a file as an argument).+--+-- All return paths start with the 'FilePath' argument.+listFilesFullPath :: FilePath -> IO [FilePath]+listFilesFullPath path = do+    -- Check if it's a file or directory:+    res <- SD.doesFileExist path+    if res+        then pure [path]+        else do+            fs <- fmap (path </>) <$> SD.listDirectory path+            concat <$> traverse listFilesFullPath fs++checkPointer :: Value -> D4.Failure -> HU.Assertion+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 -> HU.Assertion+    assertContains x y+        | x == y    = pure ()+        | otherwise =+            case (x,y) of+                (Array xs, Array ys) ->+                    HU.assertBool "Pointer resolution incorrect"+                                  (V.toList ys `isInfixOf` V.toList xs)+                (Object xhm, Object yhm) ->+                    HU.assertBool "Pointer resolution incorrect"+                                  (HM.toList yhm `isInfixOf` HM.toList xhm)+                _ -> HU.assertFailure+                        "Pointer resolution incorrect: result mismatch"++isHTTPTest :: String -> Bool+isHTTPTest file = (file == "definitions.json")+               || (file == "ref.json")+               || (file == "refRemote.json")++-- | We may never support the @"format"@ keywords, and+-- are currently failing the zeroTerminatedFloats test.+skipOptional :: String -> Bool+skipOptional file = (file == "optional/format.json")+                 || (file == "optional/zeroTerminatedFloats.json")+ data SchemaTest = SchemaTest-  { _stDescription :: Text-  , _stSchema      :: D4.Schema-  , _stCases       :: [SchemaTestCase]-  }+    { _stDescription :: Text+    , _stSchema      :: Value+    , _stCases       :: [SchemaTestCase]+    }  data SchemaTestCase = SchemaTestCase-  { _scDescription :: Text-  , _scData        :: Value-  , _scValid       :: Bool-  } deriving Generic+    { _scDescription :: Text+    , _scData        :: Value+    , _scValid       :: Bool+    } deriving Generic  instance FromJSON SchemaTest where-  parseJSON = withObject "SchemaTest" $ \o -> SchemaTest-    <$> o .: "description"-    <*> o .: "schema"-    <*> o .: "tests" -- Perhaps "cases" would have been a more descriptive key.+    parseJSON = withObject "SchemaTest" $ \o -> SchemaTest+        <$> o .: "description"+        <*> o .: "schema"+        <*> o .: "tests" -- Perhaps "cases" would have been+                         -- a more descriptive key.  instance FromJSON SchemaTestCase where-  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = fmap toLower . drop 3 }+    parseJSON = genericParseJSON+                    defaultOptions+                    { fieldLabelModifier = fmap toLower . drop 3 } -readSchemaTests :: String -> [String] -> IO [SchemaTest]-readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles+readSchemaTests+    :: String+    -- ^ The path to a directory.+    -> (String -> Bool)+    -- ^ A function to decide what we're interested in within that directory.+    -> IO [SchemaTest]+readSchemaTests dir filterFunc = do+    files <- filter filterFunc <$> listFiles dir+    concat <$> traverse fileToCases files   where     -- Each file contains an array of SchemaTests, not just one.     fileToCases :: String -> IO [SchemaTest]     fileToCases name = do-      let fullPath = dir </> name-      jsonBS <- LBS.readFile fullPath-      case eitherDecode jsonBS of-        Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e-        Right schemaTests -> pure $ prependFileName name <$> schemaTests+        let fullPath = dir </> name+        jsonBS <- LBS.readFile fullPath+        case eitherDecode jsonBS of+            Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e+            Right schemaTests -> pure $ prependFileName name <$> schemaTests      prependFileName :: String -> SchemaTest -> SchemaTest     prependFileName fileName s = s-      { _stDescription = T.pack fileName <> ": " <> _stDescription s-      }+        { _stDescription = T.pack fileName <> ": " <> _stDescription s+        } -    concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]-    concatMapM f xs = liftM concat (mapM f xs)+toTest+  :: forall schema. FromJSON schema+  => (schema -> SchemaTestCase -> HU.Assertion)+  -> SchemaTest+  -> TestTree+toTest validate st =+    HU.testCase (T.unpack (_stDescription st)) $+        forM_ (_stCases st) (validate schema)+  where+    schema :: schema+    schema = case fromJSON (_stSchema st) of+                 Error e   -> error ("Couldn't parse schema: " <> show e)+                 Success a -> a -toTest :: SchemaTest -> TestTree-toTest st =-  HU.testCase (T.unpack (_stDescription st)) $ do-    forM_ (_stCases st) $ \sc -> do-      g <- assertRight =<< D4.referencesViaHTTP (D4.SchemaWithURI (_stSchema st) Nothing)-      validate <- assertRight . D4.checkSchema g $ D4.SchemaWithURI (_stSchema st) Nothing-      let res = validate (_scData sc)-      if _scValid sc-        then assertValid   sc res-        else assertInvalid sc res+assertResult :: SchemaTestCase -> [D4.Failure] -> HU.Assertion+assertResult sc failures+    | _scValid sc = assertValid sc failures+    | otherwise   = assertInvalid sc failures -assertValid :: SchemaTestCase -> [D4.Invalid] -> HU.Assertion+assertValid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion assertValid _ [] = pure ()-assertValid sc errs =-  HU.assertFailure $ unlines-    [ "    Failed to validate data"-    , "    Description: "         <> T.unpack (_scDescription sc)-    , "    Data: "                <> show (_scData sc)-    , "    Validation failures: " <> show errs-    ]+assertValid sc failures =+    HU.assertFailure $ unlines+        [ "    Failed to validate data"+        , "    Description: "         <> T.unpack (_scDescription sc)+        , "    Data: "                <> show (_scData sc)+        , "    Validation failures: " <> show failures+        ] -assertInvalid :: SchemaTestCase -> [D4.Invalid] -> HU.Assertion+assertInvalid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion assertInvalid sc [] =-  HU.assertFailure $ unlines-    [ "    Validated invalid data"-    , "    Description: " <> T.unpack (_scDescription sc)-    , "    Data: "        <> show (_scData sc)-    ]+    HU.assertFailure $ unlines+        [ "    Validated invalid data"+        , "    Description: " <> T.unpack (_scDescription sc)+        , "    Data: "        <> show (_scData sc)+        ] assertInvalid _ _ = pure ()--assertRight :: (Show a) => Either a b -> IO b-assertRight (Left e)  = HU.assertFailure (show e) >> fail "assertRight failed"-assertRight (Right b) = pure b

@@ -0,0 +1,17 @@+[+    {+        "description": "recursive ref",+        "schema": {+            "allOf": [+                {"$ref": "#"}+            ]+        },+        "tests": [+            {+                "description": "arbitrary data",+                "data": {},+                "valid": false+            }+        ]+    }+]