diff --git a/JSON-Schema-Test-Suite/tests/draft4/optional/bignum.json b/JSON-Schema-Test-Suite/tests/draft4/optional/bignum.json new file mode 100644 --- /dev/null +++ b/JSON-Schema-Test-Suite/tests/draft4/optional/bignum.json @@ -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 + } + ] + } +] diff --git a/JSON-Schema-Test-Suite/tests/draft4/optional/format.json b/JSON-Schema-Test-Suite/tests/draft4/optional/format.json new file mode 100644 --- /dev/null +++ b/JSON-Schema-Test-Suite/tests/draft4/optional/format.json @@ -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 + } + ] + } +] diff --git a/JSON-Schema-Test-Suite/tests/draft4/optional/zeroTerminatedFloats.json b/JSON-Schema-Test-Suite/tests/draft4/optional/zeroTerminatedFloats.json new file mode 100644 --- /dev/null +++ b/JSON-Schema-Test-Suite/tests/draft4/optional/zeroTerminatedFloats.json @@ -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 + } + ] + } +] diff --git a/JSON-Schema-Test-Suite/tests/draft4/pattern.json b/JSON-Schema-Test-Suite/tests/draft4/pattern.json --- a/JSON-Schema-Test-Suite/tests/draft4/pattern.json +++ b/JSON-Schema-Test-Suite/tests/draft4/pattern.json @@ -19,5 +19,16 @@ "valid": true } ] + }, + { + "description": "pattern is not anchored", + "schema": {"pattern": "a+"}, + "tests": [ + { + "description": "matches a substring", + "data": "xxaayy", + "valid": true + } + ] } ] diff --git a/JSON-Schema-Test-Suite/tests/draft4/ref.json b/JSON-Schema-Test-Suite/tests/draft4/ref.json --- a/JSON-Schema-Test-Suite/tests/draft4/ref.json +++ b/JSON-Schema-Test-Suite/tests/draft4/ref.json @@ -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 } ] }, diff --git a/JSON-Schema-Test-Suite/tests/draft4/type.json b/JSON-Schema-Test-Suite/tests/draft4/type.json --- a/JSON-Schema-Test-Suite/tests/draft4/type.json +++ b/JSON-Schema-Test-Suite/tests/draft4/type.json @@ -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 }, diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -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. diff --git a/examples/AlternateSchema.hs b/examples/AlternateSchema.hs new file mode 100644 --- /dev/null +++ b/examples/AlternateSchema.hs @@ -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 diff --git a/examples/CustomSchema.hs b/examples/CustomSchema.hs deleted file mode 100644 --- a/examples/CustomSchema.hs +++ /dev/null @@ -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" diff --git a/examples/Full.hs b/examples/Full.hs --- a/examples/Full.hs +++ b/examples/Full.hs @@ -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." diff --git a/examples/PrettyShowFailure.hs b/examples/PrettyShowFailure.hs deleted file mode 100644 --- a/examples/PrettyShowFailure.hs +++ /dev/null @@ -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 - ] diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -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." diff --git a/examples/json/start.json b/examples/json/start.json new file mode 100644 --- /dev/null +++ b/examples/json/start.json @@ -0,0 +1,3 @@ +{ + "$ref": "./unique.json" +} diff --git a/hjsonschema.cabal b/hjsonschema.cabal --- a/hjsonschema.cabal +++ b/hjsonschema.cabal @@ -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 diff --git a/src/Data/JsonSchema/Draft4.hs b/src/Data/JsonSchema/Draft4.hs --- a/src/Data/JsonSchema/Draft4.hs +++ b/src/Data/JsonSchema/Draft4.hs @@ -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 diff --git a/src/Data/JsonSchema/Draft4/Failure.hs b/src/Data/JsonSchema/Draft4/Failure.hs --- a/src/Data/JsonSchema/Draft4/Failure.hs +++ b/src/Data/JsonSchema/Draft4/Failure.hs @@ -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 diff --git a/src/Data/JsonSchema/Draft4/Internal.hs b/src/Data/JsonSchema/Draft4/Internal.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4/Internal.hs +++ /dev/null @@ -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) diff --git a/src/Data/JsonSchema/Draft4/Schema.hs b/src/Data/JsonSchema/Draft4/Schema.hs --- a/src/Data/JsonSchema/Draft4/Schema.hs +++ b/src/Data/JsonSchema/Draft4/Schema.hs @@ -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 + } diff --git a/src/Data/JsonSchema/Draft4/Spec.hs b/src/Data/JsonSchema/Draft4/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSchema/Draft4/Spec.hs @@ -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) diff --git a/src/Data/JsonSchema/Fetch.hs b/src/Data/JsonSchema/Fetch.hs --- a/src/Data/JsonSchema/Fetch.hs +++ b/src/Data/JsonSchema/Fetch.hs @@ -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) diff --git a/src/Data/JsonSchema/Types.hs b/src/Data/JsonSchema/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSchema/Types.hs @@ -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) diff --git a/src/Data/Validator/Draft4.hs b/src/Data/Validator/Draft4.hs --- a/src/Data/Validator/Draft4.hs +++ b/src/Data/Validator/Draft4.hs @@ -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)) diff --git a/src/Data/Validator/Draft4/Any.hs b/src/Data/Validator/Draft4/Any.hs --- a/src/Data/Validator/Draft4/Any.hs +++ b/src/Data/Validator/Draft4/Any.hs @@ -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 diff --git a/src/Data/Validator/Draft4/Array.hs b/src/Data/Validator/Draft4/Array.hs --- a/src/Data/Validator/Draft4/Array.hs +++ b/src/Data/Validator/Draft4/Array.hs @@ -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 diff --git a/src/Data/Validator/Draft4/Number.hs b/src/Data/Validator/Draft4/Number.hs --- a/src/Data/Validator/Draft4/Number.hs +++ b/src/Data/Validator/Draft4/Number.hs @@ -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) diff --git a/src/Data/Validator/Draft4/Object.hs b/src/Data/Validator/Draft4/Object.hs --- a/src/Data/Validator/Draft4/Object.hs +++ b/src/Data/Validator/Draft4/Object.hs @@ -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: -- -- @@ -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 diff --git a/src/Data/Validator/Draft4/Object/Properties.hs b/src/Data/Validator/Draft4/Object/Properties.hs --- a/src/Data/Validator/Draft4/Object/Properties.hs +++ b/src/Data/Validator/Draft4/Object/Properties.hs @@ -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 diff --git a/src/Data/Validator/Draft4/String.hs b/src/Data/Validator/Draft4/String.hs --- a/src/Data/Validator/Draft4/String.hs +++ b/src/Data/Validator/Draft4/String.hs @@ -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)) diff --git a/src/Data/Validator/Failure.hs b/src/Data/Validator/Failure.hs --- a/src/Data/Validator/Failure.hs +++ b/src/Data/Validator/Failure.hs @@ -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 } diff --git a/src/Data/Validator/Reference.hs b/src/Data/Validator/Reference.hs --- a/src/Data/Validator/Reference.hs +++ b/src/Data/Validator/Reference.hs @@ -1,56 +1,44 @@ - -- | JSON Reference is described here: -- -- -- And is extended for JSON Schema here: -- --- --- 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 diff --git a/src/Data/Validator/Types.hs b/src/Data/Validator/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Validator/Types.hs @@ -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 diff --git a/src/Data/Validator/Utils.hs b/src/Data/Validator/Utils.hs --- a/src/Data/Validator/Utils.hs +++ b/src/Data/Validator/Utils.hs @@ -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 diff --git a/test/Local.hs b/test/Local.hs --- a/test/Local.hs +++ b/test/Local.hs @@ -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 + ] diff --git a/test/Local/Failure.hs b/test/Local/Failure.hs --- a/test/Local/Failure.hs +++ b/test/Local/Failure.hs @@ -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 + } diff --git a/test/Local/Filesystem.hs b/test/Local/Filesystem.hs deleted file mode 100644 --- a/test/Local/Filesystem.hs +++ /dev/null @@ -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: " diff --git a/test/Local/Reference.hs b/test/Local/Reference.hs --- a/test/Local/Reference.hs +++ b/test/Local/Reference.hs @@ -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") diff --git a/test/Local/Validation.hs b/test/Local/Validation.hs new file mode 100644 --- /dev/null +++ b/test/Local/Validation.hs @@ -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 () diff --git a/test/Remote.hs b/test/Remote.hs --- a/test/Remote.hs +++ b/test/Remote.hs @@ -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" diff --git a/test/Shared.hs b/test/Shared.hs --- a/test/Shared.hs +++ b/test/Shared.hs @@ -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 diff --git a/test/supplement/recurse.json b/test/supplement/recurse.json new file mode 100644 --- /dev/null +++ b/test/supplement/recurse.json @@ -0,0 +1,17 @@ +[ + { + "description": "recursive ref", + "schema": { + "allOf": [ + {"$ref": "#"} + ] + }, + "tests": [ + { + "description": "arbitrary data", + "data": {}, + "valid": false + } + ] + } +]