diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +# 1.4.0.0 + ++ Rename `Data.JsonSchema.*` modules to `JSONSchema.*`. ++ Rename `Data.Validator.*` modules to `JSONSchema.Validator.*`. + # 1.3.0.1 + Bump `vector`. diff --git a/examples/AlternateSchema.hs b/examples/AlternateSchema.hs --- a/examples/AlternateSchema.hs +++ b/examples/AlternateSchema.hs @@ -1,8 +1,8 @@ -- | An implementation of JSON Schema Draft 4 based on 'HashMap Text Value' --- instead of a custom record type like 'Data.JsonSchema.Draft4'. +-- instead of a custom record type like 'JSONSchema.Draft4'. -- -- If you're writing code for a new schema specification you probably want --- to copy this module instead of the 'Data.JsonSchema.Draft4'. While it's +-- to copy this module instead of the 'JSONSchema.Draft4'. While it's -- less convenient to write schemas in Haskell without a record type, you -- can get the implementation finished with far fewer lines of code. @@ -10,23 +10,23 @@ import Protolude -import Data.Aeson (FromJSON(..), Value(..), - decode) -import qualified Data.Aeson as AE -import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) -import Data.Profunctor (Profunctor (..)) +import Data.Aeson (FromJSON(..), Value(..), + decode) +import qualified Data.Aeson as AE +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import Data.Profunctor (Profunctor (..)) -import Data.JsonSchema.Draft4 (ValidatorFailure(..), - metaSchemaBytes) -import Data.JsonSchema.Fetch (ReferencedSchemas(..), - SchemaWithURI(..)) -import qualified Data.JsonSchema.Fetch as FE -import Data.JsonSchema.Types (Schema(..), Spec(..)) -import qualified Data.JsonSchema.Types as JT -import qualified Data.Validator.Draft4 as D4 -import Data.Validator.Reference (updateResolutionScope) +import JSONSchema.Draft4 (ValidatorFailure(..), + metaSchemaBytes) +import JSONSchema.Fetch (ReferencedSchemas(..), + SchemaWithURI(..)) +import qualified JSONSchema.Fetch as FE +import JSONSchema.Types (Schema(..), Spec(..)) +import qualified JSONSchema.Types as JT +import qualified JSONSchema.Validator.Draft4 as D4 +import JSONSchema.Validator.Reference (updateResolutionScope) -------------------------------------------------- -- * Basic fetching tools @@ -107,7 +107,7 @@ -> Maybe Text -> Spec Schema ValidatorFailure -- ^ Here we reuses 'ValidatorFailure' from - -- 'Data.JsonSchema.Draft4.Failure'. If your validators have different + -- 'JSONSchema.Draft4.Failure'. If your validators have different -- failure possibilities you'll need to create your own validator -- failure type. d4Spec referenced visited scope = diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -3,12 +3,12 @@ import Protolude -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 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 +import qualified JSONSchema.Draft4 as D4 badData :: Value badData = toJSON [True, True] diff --git a/examples/TwoStep.hs b/examples/TwoStep.hs --- a/examples/TwoStep.hs +++ b/examples/TwoStep.hs @@ -15,11 +15,11 @@ import Protolude -import Data.Aeson (Value (..), toJSON) -import qualified Data.List.NonEmpty as NE +import Data.Aeson (Value (..), toJSON) +import qualified Data.List.NonEmpty as NE -import qualified Data.JsonSchema.Draft4 as D4 -import qualified Data.Validator.Draft4 as VAL +import qualified JSONSchema.Draft4 as D4 +import qualified JSONSchema.Validator.Draft4 as VAL schema :: D4.Schema schema = D4.emptySchema { D4._schemaRef = Just "./unique.json" } diff --git a/hjsonschema.cabal b/hjsonschema.cabal --- a/hjsonschema.cabal +++ b/hjsonschema.cabal @@ -1,5 +1,5 @@ name: hjsonschema -version: 1.3.0.1 +version: 1.4.0.0 synopsis: JSON Schema library homepage: https://github.com/seagreen/hjsonschema license: MIT @@ -38,23 +38,23 @@ ghc-options: -Wall exposed-modules: - Data.JsonSchema.Draft4 - , Data.JsonSchema.Draft4.Failure - , Data.JsonSchema.Draft4.Schema - , Data.JsonSchema.Draft4.Spec - , Data.JsonSchema.Fetch - , Data.JsonSchema.Types - , Data.Validator.Draft4 - , Data.Validator.Draft4.Any - , Data.Validator.Draft4.Array - , Data.Validator.Draft4.Number - , Data.Validator.Draft4.Object - , Data.Validator.Draft4.String - , Data.Validator.Reference - , Data.Validator.Types - , Data.Validator.Utils + JSONSchema.Draft4 + , JSONSchema.Draft4.Failure + , JSONSchema.Draft4.Schema + , JSONSchema.Draft4.Spec + , JSONSchema.Fetch + , JSONSchema.Types + , JSONSchema.Validator.Draft4 + , JSONSchema.Validator.Draft4.Any + , JSONSchema.Validator.Draft4.Array + , JSONSchema.Validator.Draft4.Number + , JSONSchema.Validator.Draft4.Object + , JSONSchema.Validator.Draft4.String + , JSONSchema.Validator.Reference + , JSONSchema.Validator.Types + , JSONSchema.Validator.Utils other-modules: - Data.Validator.Draft4.Object.Properties + JSONSchema.Validator.Draft4.Object.Properties , Import build-depends: base >= 4.7 && < 4.10 diff --git a/src/Data/JsonSchema/Draft4.hs b/src/Data/JsonSchema/Draft4.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Data.JsonSchema.Draft4 - ( -- * Draft 4 Schema - SchemaWithURI(..) - , Schema(..) - , SC.emptySchema - - -- * One-step validation (getting references over HTTP) - , fetchHTTPAndValidate - , HTTPValidationFailure(..) - , FE.HTTPFailure(..) - , SchemaInvalid(..) - - -- * One-step validation (getting references from the filesystem) - , fetchFilesystemAndValidate - , FilesystemValidationFailure(..) - , FE.FilesystemFailure(..) - - -- * Validation failure - , Invalid(..) - , ValidatorFailure(..) - - -- * Fetching tools - , ReferencedSchemas(..) - , FE.URISchemaMap(..) - , referencesViaHTTP - , referencesViaFilesystem - - -- * Other Draft 4 things exported just in case - , metaSchema - , metaSchemaBytes - , schemaValidity - , referencesValidity - , checkSchema - , draft4FetchInfo - ) where - -import Import - -import Control.Arrow (left) -import qualified Data.ByteString as BS -import Data.FileEmbed (embedFile, - makeRelativeToProject) -import qualified Data.HashMap.Strict as HM -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) - -import Data.JsonSchema.Draft4.Failure (Invalid(..), - SchemaInvalid(..), - ValidatorFailure(..)) -import Data.JsonSchema.Draft4.Schema (Schema) -import qualified Data.JsonSchema.Draft4.Schema as SC -import qualified Data.JsonSchema.Draft4.Spec as Spec -import Data.JsonSchema.Fetch (ReferencedSchemas(..), - SchemaWithURI(..)) -import qualified Data.JsonSchema.Fetch as FE - -data HTTPValidationFailure - = HVRequest FE.HTTPFailure - | HVSchema SchemaInvalid - | HVData Invalid - deriving Show - --- | Fetch recursively referenced schemas over HTTP, check that both the --- original and referenced schemas are valid, then validate then data. -fetchHTTPAndValidate - :: SchemaWithURI Schema - -> Value - -> IO (Either HTTPValidationFailure ()) -fetchHTTPAndValidate sw v = do - res <- referencesViaHTTP sw - pure (g =<< f =<< left HVRequest res) - where - f :: FE.URISchemaMap Schema - -> Either HTTPValidationFailure (Value -> [ValidatorFailure]) - f references = left HVSchema (checkSchema references sw) - - g :: (Value -> [ValidatorFailure]) -> Either HTTPValidationFailure () - g val = case NE.nonEmpty (val v) of - Nothing -> Right () - Just failures -> Left (HVData Invalid - { _invalidSchema = _swSchema sw - , _invalidInstance = v - , _invalidFailures = failures - }) - -data FilesystemValidationFailure - = FVRead FE.FilesystemFailure - | FVSchema SchemaInvalid - | FVData Invalid - deriving (Show, Eq) - --- | Fetch recursively referenced schemas from the filesystem, check --- that both the original and referenced schemas are valid, then validate --- the data. -fetchFilesystemAndValidate - :: SchemaWithURI Schema - -> Value - -> IO (Either FilesystemValidationFailure ()) -fetchFilesystemAndValidate sw v = do - res <- referencesViaFilesystem sw - pure (g =<< f =<< left FVRead res) - where - f :: FE.URISchemaMap Schema - -> Either FilesystemValidationFailure (Value -> [ValidatorFailure]) - f references = left FVSchema (checkSchema references sw) - - g :: (Value -> [ValidatorFailure]) -> Either FilesystemValidationFailure () - g val = case NE.nonEmpty (val v) of - Nothing -> Right () - Just invalid -> Left (FVData Invalid - { _invalidSchema = _swSchema sw - , _invalidInstance = v - , _invalidFailures = invalid - }) - --- | An instance of 'Data.JsonSchema.Fetch.FetchInfo' specialized for --- JSON Schema Draft 4. -draft4FetchInfo :: FE.FetchInfo Schema -draft4FetchInfo = FE.FetchInfo Spec.embedded SC._schemaId SC._schemaRef - --- | Fetch the schemas recursively referenced by a starting schema over HTTP. -referencesViaHTTP - :: SchemaWithURI Schema - -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema)) -referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo - --- | Fetch the schemas recursively referenced by a starting schema from --- the filesystem. -referencesViaFilesystem - :: SchemaWithURI Schema - -> IO (Either FE.FilesystemFailure (FE.URISchemaMap Schema)) -referencesViaFilesystem = FE.referencesViaFilesystem' draft4FetchInfo - --- | Checks if a schema and a set of referenced schemas are valid. --- --- Return a function to validate data. -checkSchema - :: FE.URISchemaMap Schema - -> SchemaWithURI Schema - -> Either SchemaInvalid (Value -> [ValidatorFailure]) -checkSchema sm sw = - case NE.nonEmpty failures of - Just fs -> Left (SchemaInvalid fs) - Nothing -> Right (Spec.specValidate - (ReferencedSchemas (_swSchema sw) - (FE._unURISchemaMap sm)) - sw) - where - failures :: [(Maybe Text, NonEmpty ValidatorFailure)] - failures = - let refFailures = first Just <$> referencesValidity sm - in case NE.nonEmpty (schemaValidity (_swSchema sw)) of - Nothing -> refFailures - Just errs -> (Nothing,errs) : refFailures - -metaSchema :: Schema -metaSchema = - fromMaybe (panic "Schema decode failed (this should never happen)") - . decodeStrict - $ metaSchemaBytes - -metaSchemaBytes :: BS.ByteString -metaSchemaBytes = - $(makeRelativeToProject "src/draft4.json" >>= embedFile) - --- | Check that a schema itself is valid --- (if so the returned list will be empty). -schemaValidity :: Schema -> [ValidatorFailure] -schemaValidity = - Spec.specValidate referenced (SchemaWithURI metaSchema Nothing) . toJSON - where - referenced :: ReferencedSchemas Schema - referenced = ReferencedSchemas - metaSchema - (HM.singleton "http://json-schema.org/draft-04/schema" - metaSchema) - --- | Check that a set of referenced schemas are valid --- (if so the returned list will be empty). -referencesValidity - :: FE.URISchemaMap Schema - -> [(Text, NonEmpty ValidatorFailure)] - -- ^ The first item of the tuple is the URI of a schema, the second - -- is that schema's validation errors. -referencesValidity = HM.foldlWithKey' f mempty . FE._unURISchemaMap - where - f :: [(Text, NonEmpty ValidatorFailure)] - -> Text - -> Schema - -> [(Text, NonEmpty ValidatorFailure)] - f acc k v = case NE.nonEmpty (schemaValidity v) of - Nothing -> acc - Just errs -> (k,errs) : acc diff --git a/src/Data/JsonSchema/Draft4/Failure.hs b/src/Data/JsonSchema/Draft4/Failure.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4/Failure.hs +++ /dev/null @@ -1,59 +0,0 @@ - -module Data.JsonSchema.Draft4.Failure where - -import Import - -import Data.JsonSchema.Draft4.Schema (Schema) -import qualified Data.Validator.Draft4 as D4 - --- | Used to report an entire instance being invalidated, as opposed --- to the failure of a single validator. -data Invalid = Invalid - { _invalidSchema :: Schema - , _invalidInstance :: Value - , _invalidFailures :: NonEmpty ValidatorFailure - } deriving (Eq, Show) - -data ValidatorFailure - = FailureMultipleOf D4.MultipleOfInvalid - | FailureMaximum D4.MaximumInvalid - | FailureMinimum D4.MinimumInvalid - - | FailureMaxLength D4.MaxLengthInvalid - | FailureMinLength D4.MinLengthInvalid - | FailurePattern D4.PatternInvalid - - | FailureMaxItems D4.MaxItemsInvalid - | FailureMinItems D4.MinItemsInvalid - | FailureUniqueItems D4.UniqueItemsInvalid - | FailureItems (D4.ItemsInvalid ValidatorFailure) - | FailureAdditionalItems (D4.AdditionalItemsInvalid ValidatorFailure) - - | FailureMaxProperties D4.MaxPropertiesInvalid - | FailureMinProperties D4.MinPropertiesInvalid - | FailureRequired () - | FailureDependencies (D4.DependenciesInvalid ValidatorFailure) - | FailurePropertiesRelated (D4.PropertiesRelatedInvalid ValidatorFailure) - - | FailureRef (D4.RefInvalid ValidatorFailure) - | FailureEnum D4.EnumInvalid - | FailureType D4.TypeValidatorInvalid - | FailureAllOf (D4.AllOfInvalid ValidatorFailure) - | FailureAnyOf (D4.AnyOfInvalid ValidatorFailure) - | FailureOneOf (D4.OneOfInvalid ValidatorFailure) - | FailureNot D4.NotValidatorInvalid - deriving (Eq, Show) - --- | A description of why a schema (or one of its reference) is itself --- invalid. --- --- 'Nothing' indicates the starting schema. 'Just' indicates a referenced --- schema. The contents of the 'Just' is the schema's URI. --- --- NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of --- defining this, but then we lose the guarantee that there's at least --- one key. -newtype SchemaInvalid - = SchemaInvalid { - _unSchemaInvalid :: NonEmpty (Maybe Text, NonEmpty ValidatorFailure) } - deriving (Eq, Show) diff --git a/src/Data/JsonSchema/Draft4/Schema.hs b/src/Data/JsonSchema/Draft4/Schema.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4/Schema.hs +++ /dev/null @@ -1,342 +0,0 @@ - -module Data.JsonSchema.Draft4.Schema where - -import Import hiding (mapMaybe) - -import qualified Data.HashMap.Strict as HM -import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (fromJust, isJust) -import Data.Scientific -import qualified Data.Set as Set -import qualified Data.Text as T - -import qualified Data.Validator.Draft4 as D4 -import Data.Validator.Utils - -data Schema = Schema - { _schemaVersion :: Maybe Text - , _schemaId :: Maybe Text - , _schemaRef :: Maybe Text - , _schemaDefinitions :: Maybe (HashMap Text Schema) - -- ^ A standardized location for embedding schemas - -- to be referenced from elsewhere in the document. - , _schemaOther :: HashMap Text Value - -- ^ Since the JSON document this schema was built from could - -- contain schemas anywhere (not just in "definitions" or any - -- of the other official keys) we save any leftover key/value - -- pairs not covered by them here. - -- - -- TODO: This field is the source of most of the complication in this - -- module and needs to be removed. It should be doable, though it will - -- involve some modification to the fetching code. - - , _schemaMultipleOf :: Maybe Scientific - , _schemaMaximum :: Maybe Scientific - , _schemaExclusiveMaximum :: Maybe Bool - , _schemaMinimum :: Maybe Scientific - , _schemaExclusiveMinimum :: Maybe Bool - - , _schemaMaxLength :: Maybe Int - , _schemaMinLength :: Maybe Int - , _schemaPattern :: Maybe Text - - , _schemaMaxItems :: Maybe Int - , _schemaMinItems :: Maybe Int - , _schemaUniqueItems :: Maybe Bool - , _schemaItems :: Maybe (D4.Items Schema) - -- Note that '_schemaAdditionalItems' is left out of 'runValidate' - -- because its functionality is handled by '_schemaItems'. It always - -- validates data unless 'Items' is present. - , _schemaAdditionalItems :: Maybe (D4.AdditionalItems Schema) - - , _schemaMaxProperties :: Maybe Int - , _schemaMinProperties :: Maybe Int - , _schemaRequired :: Maybe (Set Text) - , _schemaDependencies :: Maybe (HashMap Text (D4.Dependency Schema)) - , _schemaProperties :: Maybe (HashMap Text Schema) - , _schemaPatternProperties :: Maybe (HashMap Text Schema) - , _schemaAdditionalProperties :: Maybe (D4.AdditionalProperties Schema) - - , _schemaEnum :: Maybe (NonEmpty Value) - , _schemaType :: Maybe D4.TypeValidator - , _schemaAllOf :: Maybe (NonEmpty Schema) - , _schemaAnyOf :: Maybe (NonEmpty Schema) - , _schemaOneOf :: Maybe (NonEmpty Schema) - , _schemaNot :: Maybe Schema - } deriving (Eq, Show) - -emptySchema :: Schema -emptySchema = Schema - { _schemaVersion = Nothing - , _schemaId = Nothing - , _schemaRef = Nothing - , _schemaDefinitions = Nothing - , _schemaOther = mempty - - , _schemaMultipleOf = Nothing - , _schemaMaximum = Nothing - , _schemaExclusiveMaximum = Nothing - , _schemaMinimum = Nothing - , _schemaExclusiveMinimum = Nothing - - , _schemaMaxLength = Nothing - , _schemaMinLength = Nothing - , _schemaPattern = Nothing - - , _schemaMaxItems = Nothing - , _schemaMinItems = Nothing - , _schemaUniqueItems = Nothing - , _schemaItems = Nothing - , _schemaAdditionalItems = Nothing - - , _schemaMaxProperties = Nothing - , _schemaMinProperties = Nothing - , _schemaRequired = Nothing - , _schemaDependencies = Nothing - , _schemaProperties = Nothing - , _schemaPatternProperties = Nothing - , _schemaAdditionalProperties = Nothing - - , _schemaEnum = Nothing - , _schemaType = Nothing - , _schemaAllOf = Nothing - , _schemaAnyOf = Nothing - , _schemaOneOf = Nothing - , _schemaNot = Nothing - } - -instance FromJSON Schema where - parseJSON = withObject "Schema" $ \o -> do - a <- o .:! "$schema" - b <- o .:! "id" - c <- o .:! "$ref" - d <- o .:! "definitions" - e <- parseJSON (Object (HM.difference o internalSchemaHashMap)) - - f <- o .:! "multipleOf" - g <- o .:! "maximum" - h <- o .:! "exclusiveMaximum" - i <- o .:! "minimum" - j <- o .:! "exclusiveMinimum" - - k <- o .:! "maxLength" - l <- o .:! "minLength" - m <- o .:! "pattern" - - n <- o .:! "maxItems" - o' <- o .:! "minItems" - p <- o .:! "uniqueItems" - q <- o .:! "items" - r <- o .:! "additionalItems" - - s <- o .:! "maxProperties" - t <- o .:! "minProperties" - u <- o .:! "required" - v <- o .:! "dependencies" - w <- o .:! "properties" - x <- o .:! "patternProperties" - y <- o .:! "additionalProperties" - - z <- o .:! "enum" - a2 <- o .:! "type" - b2 <- fmap _unNonEmpty' <$> o .:! "allOf" - c2 <- fmap _unNonEmpty' <$> o .:! "anyOf" - d2 <- fmap _unNonEmpty' <$> o .:! "oneOf" - e2 <- o .:! "not" - pure Schema - { _schemaVersion = a - , _schemaId = b - , _schemaRef = c - , _schemaDefinitions = d - , _schemaOther = e - - , _schemaMultipleOf = f - , _schemaMaximum = g - , _schemaExclusiveMaximum = h - , _schemaMinimum = i - , _schemaExclusiveMinimum = j - - , _schemaMaxLength = k - , _schemaMinLength = l - , _schemaPattern = m - - , _schemaMaxItems = n - , _schemaMinItems = o' - , _schemaUniqueItems = p - , _schemaItems = q - , _schemaAdditionalItems = r - - , _schemaMaxProperties = s - , _schemaMinProperties = t - , _schemaRequired = u - , _schemaDependencies = v - , _schemaProperties = w - , _schemaPatternProperties = x - , _schemaAdditionalProperties = y - - , _schemaEnum = z - , _schemaType = a2 - , _schemaAllOf = b2 - , _schemaAnyOf = c2 - , _schemaOneOf = d2 - , _schemaNot = e2 - } - -instance ToJSON Schema where - -- | The way we resolve JSON Pointers to embedded schemas is by - -- serializing the containing schema to a value and then resolving the - -- pointer against it. This means that FromJSON and ToJSON must be - -- isomorphic. - -- - -- This influences the design choices in the library. E.g. right now - -- there are two false values for "exclusiveMaximum" -- Nothing and - -- Just False. We could have condensed them down by using () instead - -- of Bool for "exclusiveMaximum". This would have made writing schemas - -- in haskell easier, but we could no longer round trip through/from - -- JSON without losing information. - toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap) - (toJSON <$> _schemaOther s) - where - -- 'mapMaybe' is provided by unordered-containers after - -- unordered-container-2.6.0.0, but until that is a little older - -- (and has time to get into Stackage etc.) we use our own - -- implementation. - mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 - mapMaybe f = fmap fromJust . HM.filter isJust . fmap f - --- | Internal. Separate from ToJSON because it's also used --- by FromJSON to determine what keys aren't official schema --- keys and therefor should be included in _schemaOther. -internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value) -internalSchemaHashMap = HM.fromList - [ ("$schema" , f _schemaVersion) - , ("id" , f _schemaId) - , ("$ref" , f _schemaRef) - , ("definitions" , f _schemaDefinitions) - - , ("multipleOf" , f _schemaMultipleOf) - , ("maximum" , f _schemaMaximum) - , ("exclusiveMaximum" , f _schemaExclusiveMaximum) - , ("minimum" , f _schemaMinimum) - , ("exclusiveMinimum" , f _schemaExclusiveMinimum) - - , ("maxLength" , f _schemaMaxLength) - , ("minLength" , f _schemaMinLength) - , ("pattern" , f _schemaPattern) - - , ("maxItems" , f _schemaMaxItems) - , ("minItems" , f _schemaMinItems) - , ("uniqueItems" , f _schemaUniqueItems) - , ("items" , f _schemaItems) - , ("additionalItems" , f _schemaAdditionalItems) - - , ("maxProperties" , f _schemaMaxProperties) - , ("minProperties" , f _schemaMinProperties) - , ("required" , f _schemaRequired) - , ("dependencies" , f _schemaDependencies) - , ("properties" , f _schemaProperties) - , ("patternProperties" , f _schemaPatternProperties) - , ("additionalProperties", f _schemaAdditionalProperties) - - , ("enum" , f _schemaEnum) - , ("type" , f _schemaType) - , ("allOf" , f (fmap NonEmpty' . _schemaAllOf)) - , ("anyOf" , f (fmap NonEmpty' . _schemaAnyOf)) - , ("oneOf" , f (fmap NonEmpty' . _schemaOneOf)) - , ("not" , f _schemaNot) - ] - where - f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value - f = (fmap.fmap) toJSON - -instance Arbitrary Schema where - arbitrary = sized f - where - maybeGen :: Gen a -> Gen (Maybe a) - maybeGen a = oneof [pure Nothing, Just <$> a] - - maybeRecurse :: Int -> Gen a -> Gen (Maybe a) - maybeRecurse n a - | n < 1 = pure Nothing - | otherwise = maybeGen $ resize (n `div` 10) a - - f :: Int -> Gen Schema - f n = do - a <- maybeGen arbitraryText - b <- maybeGen arbitraryText - c <- maybeGen arbitraryText - -- NOTE: The next two fields are empty to generate cleaner - -- schemas, but note that this means we don't test the - -- invertability of these fields. - d <- pure Nothing -- _schemaDefinitions - e <- pure mempty -- _otherPairs - - f' <- maybeGen arbitraryPositiveScientific - g <- maybeGen arbitraryScientific - h <- arbitrary - i <- maybeGen arbitraryScientific - j <- arbitrary - - k <- maybeGen (getPositive <$> arbitrary) - l <- maybeGen (getPositive <$> arbitrary) - m <- maybeGen arbitraryText - - n' <- maybeGen (getPositive <$> arbitrary) - o <- maybeGen (getPositive <$> arbitrary) - p <- arbitrary - q <- maybeRecurse n arbitrary - r <- maybeRecurse n arbitrary - - s <- maybeGen (getPositive <$> arbitrary) - t <- maybeGen (getPositive <$> arbitrary) - u <- maybeGen (Set.map T.pack <$> arbitrary) - v <- maybeRecurse n arbitraryHashMap - w <- maybeRecurse n arbitraryHashMap - x <- maybeRecurse n arbitraryHashMap - y <- maybeRecurse n arbitrary - - z <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty' - <$> arbitrary) - a2 <- arbitrary - b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) - c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) - d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) - e2 <- maybeRecurse n arbitrary - pure Schema - { _schemaVersion = a - , _schemaId = b - , _schemaRef = c - , _schemaDefinitions = d - , _schemaOther = e - - , _schemaMultipleOf = f' - , _schemaMaximum = g - , _schemaExclusiveMaximum = h - , _schemaMinimum = i - , _schemaExclusiveMinimum = j - - , _schemaMaxLength = k - , _schemaMinLength = l - , _schemaPattern = m - - , _schemaMaxItems = n' - , _schemaMinItems = o - , _schemaUniqueItems = p - , _schemaItems = q - , _schemaAdditionalItems = r - - , _schemaMaxProperties = s - , _schemaMinProperties = t - , _schemaRequired = u - , _schemaDependencies = v - , _schemaProperties = w - , _schemaPatternProperties = x - , _schemaAdditionalProperties = y - - , _schemaEnum = z - , _schemaType = a2 - , _schemaAllOf = b2 - , _schemaAnyOf = c2 - , _schemaOneOf = d2 - , _schemaNot = e2 - } diff --git a/src/Data/JsonSchema/Draft4/Spec.hs b/src/Data/JsonSchema/Draft4/Spec.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Draft4/Spec.hs +++ /dev/null @@ -1,128 +0,0 @@ - -module Data.JsonSchema.Draft4.Spec where - -import Import - -import Data.Maybe (fromMaybe) -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 Data.Validator.Draft4 -import Data.Validator.Reference (updateResolutionScope) - -embedded :: Schema -> ([Schema], [Schema]) -embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s - -specValidate - :: ReferencedSchemas Schema - -> SchemaWithURI Schema - -> Value - -> [ValidatorFailure] -specValidate rs = - continueValidating rs (VisitedSchemas [(Nothing, Nothing)]) - -continueValidating - :: ReferencedSchemas Schema - -> VisitedSchemas - -> SchemaWithURI Schema - -> Value - -> [ValidatorFailure] -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 - -> VisitedSchemas - -> Maybe Text - -> Spec Schema ValidatorFailure -d4Spec referenced visited scope = Spec - [ dimap (fmap MultipleOf . _schemaMultipleOf) FailureMultipleOf multipleOfValidator - , dimap - (\s -> Maximum (fromMaybe False (_schemaExclusiveMaximum s)) <$> _schemaMaximum s) - FailureMaximum - maximumValidator - , dimap - (\s -> Minimum (fromMaybe False (_schemaExclusiveMinimum s)) <$> _schemaMinimum s) - FailureMinimum - minimumValidator - - , dimap (fmap MaxLength . _schemaMaxLength) FailureMaxLength maxLengthValidator - , dimap (fmap MinLength . _schemaMinLength) FailureMinLength minLengthValidator - , dimap (fmap PatternValidator . _schemaPattern) FailurePattern patternValidator - - , dimap (fmap MaxItems . _schemaMaxItems) FailureMaxItems maxItemsValidator - , dimap (fmap MinItems . _schemaMinItems) FailureMinItems minItemsValidator - , dimap (fmap UniqueItems . _schemaUniqueItems) FailureUniqueItems uniqueItemsValidator - , dimap - (\s -> ItemsRelated - { _irItems = _schemaItems s - , _irAdditional = _schemaAdditionalItems s - }) - (\err -> case err of - IRInvalidItems e -> FailureItems e - IRInvalidAdditional e -> FailureAdditionalItems e) - (itemsRelatedValidator descend) - , lmap (fmap Definitions . _schemaDefinitions) definitionsEmbedded - - , dimap - (fmap MaxProperties . _schemaMaxProperties) - FailureMaxProperties - maxPropertiesValidator - , dimap - (fmap MinProperties . _schemaMinProperties) - FailureMinProperties - minPropertiesValidator - , dimap (fmap Required . _schemaRequired) FailureRequired requiredValidator - , dimap - (fmap DependenciesValidator . _schemaDependencies) - FailureDependencies - (dependenciesValidator descend) - , dimap - (\s -> PropertiesRelated - { _propProperties = _schemaProperties s - , _propPattern = _schemaPatternProperties s - , _propAdditional = _schemaAdditionalProperties s - }) - FailurePropertiesRelated - (propertiesRelatedValidator descend) - - , dimap - (\s -> Ref <$> _schemaRef s) - FailureRef - (refValidator visited scope (FE.getReference referenced) getRef) - , dimap (fmap EnumValidator . _schemaEnum) FailureEnum enumValidator - , dimap (fmap TypeContext . _schemaType) FailureType typeValidator - , dimap (fmap AllOf . _schemaAllOf) FailureAllOf (allOfValidator lateral) - , dimap (fmap AnyOf . _schemaAnyOf) FailureAnyOf (anyOfValidator lateral) - , dimap (fmap OneOf . _schemaOneOf) FailureOneOf (oneOfValidator lateral) - , dimap (fmap NotValidator . _schemaNot) FailureNot (notValidator lateral) - ] - where - getRef - :: VisitedSchemas - -> Maybe Text - -> Schema - -> Value - -> [ValidatorFailure] - getRef newVisited newScope schema = - continueValidating referenced newVisited (SchemaWithURI schema newScope) - - descend :: Schema -> Value -> [ValidatorFailure] - descend schema = - continueValidating referenced mempty (SchemaWithURI schema scope) - - lateral :: Schema -> Value -> [ValidatorFailure] - lateral schema = - continueValidating referenced visited (SchemaWithURI schema scope) diff --git a/src/Data/JsonSchema/Fetch.hs b/src/Data/JsonSchema/Fetch.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Fetch.hs +++ /dev/null @@ -1,194 +0,0 @@ - -module Data.JsonSchema.Fetch where - -import Import - -import Control.Arrow (left) -import Control.Exception (IOException, catch) -import Control.Monad (foldM) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import qualified Network.HTTP.Client as NC - -import Data.Validator.Reference (resolveReference, - updateResolutionScope) - --------------------------------------------------- --- * Types --------------------------------------------------- - --- | This is all the fetching functions need to know about a particular --- JSON Schema draft, e.g. JSON Schema Draft 4. -data FetchInfo schema = FetchInfo - { _fiEmbedded :: schema -> ([schema], [schema]) - , _fiId :: schema -> Maybe Text - , _fiRef :: schema -> Maybe Text - } - -data ReferencedSchemas schema = ReferencedSchemas - { _rsStarting :: !schema - -- ^ Used to resolve relative references when we don't know what the scope - -- of the current schema is. This only happens with starting schemas - -- because if we're using a remote schema we had to know its URI in order - -- to fetch it. - -- - -- Tracking the starting schema (instead of just resolving the reference to - -- the current schema being used for validation) is necessary for cases - -- where schemas are embedded inside one another. For instance in this - -- case not distinguishing the starting and "foo" schemas sends the code - -- into an infinite loop: - -- - -- { - -- "additionalProperties": false, - -- "properties": { - -- "foo": { - -- "$ref": "#" - -- } - -- } - -- } - , _rsSchemaMap :: !(HashMap Text schema) - -- ^ Map of URIs to schemas. - } deriving (Eq, Show) - --- | Keys are URIs (without URI fragments). -newtype URISchemaMap schema - = URISchemaMap { _unURISchemaMap :: HashMap Text schema } - deriving (Eq, Show) - -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) = HM.lookup t (_rsSchemaMap referenced) - --------------------------------------------------- --- * Fetch via HTTP --------------------------------------------------- - -data HTTPFailure - = HTTPParseFailure Text - | HTTPRequestFailure NC.HttpException - deriving Show - --- | Take a schema. Retrieve every document either it or its subschemas --- include via the "$ref" keyword. -referencesViaHTTP' - :: forall schema. FromJSON schema - => FetchInfo schema - -> SchemaWithURI schema - -> IO (Either HTTPFailure (URISchemaMap schema)) -referencesViaHTTP' info sw = do - manager <- NC.newManager NC.defaultManagerSettings - let f = referencesMethodAgnostic (getURL manager) info sw - catch (left HTTPParseFailure <$> f) handler - where - getURL :: NC.Manager -> Text -> IO BS.ByteString - getURL man url = do - request <- NC.parseUrlThrow (T.unpack url) - LBS.toStrict . NC.responseBody <$> NC.httpLbs request man - - handler - :: NC.HttpException - -> IO (Either HTTPFailure (URISchemaMap schema)) - handler = pure . Left . HTTPRequestFailure - --------------------------------------------------- --- * Fetch via Filesystem --------------------------------------------------- - -data FilesystemFailure - = FSParseFailure Text - | FSReadFailure IOException - deriving (Show, Eq) - -referencesViaFilesystem' - :: forall schema. FromJSON schema - => FetchInfo schema - -> SchemaWithURI schema - -> IO (Either FilesystemFailure (URISchemaMap schema)) -referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler - where - f :: IO (Either Text (URISchemaMap schema)) - f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw - - handler - :: IOException - -> IO (Either FilesystemFailure (URISchemaMap schema)) - handler = pure . Left . FSReadFailure - --------------------------------------------------- --- * Method Agnostic Fetching Tools --------------------------------------------------- - --- | A version of 'fetchReferencedSchema's where the function to fetch --- schemas is provided by the user. This allows restrictions to be added, --- e.g. rejecting non-local URIs. -referencesMethodAgnostic - :: forall schema. FromJSON schema - => (Text -> IO BS.ByteString) - -> FetchInfo schema - -> SchemaWithURI schema - -> IO (Either Text (URISchemaMap schema)) -referencesMethodAgnostic fetchRef info = - getRecursiveReferences fetchRef info (URISchemaMap mempty) - -getRecursiveReferences - :: forall schema. FromJSON schema - => (Text -> IO BS.ByteString) - -> FetchInfo schema - -> URISchemaMap schema - -> SchemaWithURI schema - -> IO (Either Text (URISchemaMap schema)) -getRecursiveReferences fetchRef info referenced sw = - foldM f (Right referenced) (includeSubschemas info sw) - where - f :: Either Text (URISchemaMap schema) - -> SchemaWithURI schema - -> IO (Either Text (URISchemaMap schema)) - f (Left e) _ = pure (Left e) - f (Right (URISchemaMap usm)) (SchemaWithURI schema mUri) = - case newRef of - Nothing -> pure (Right (URISchemaMap usm)) - Just uri -> do - bts <- fetchRef uri - case eitherDecodeStrict bts of - Left e -> pure . Left . T.pack $ e - Right schm -> getRecursiveReferences - fetchRef - info - (URISchemaMap (HM.insert uri schm usm)) - (SchemaWithURI schm (Just uri)) - where - newRef :: Maybe Text - newRef - | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema - = case HM.lookup uri usm of - Nothing -> Just uri - Just _ -> Nothing - | otherwise = Nothing - --- | Return the schema passed in as an argument, as well as every --- subschema contained within it. -includeSubschemas - :: forall schema. - FetchInfo schema - -> SchemaWithURI schema - -> [SchemaWithURI schema] -includeSubschemas info (SchemaWithURI schema mUri) = - SchemaWithURI schema mUri - : (includeSubschemas info =<< subSchemas) - where - subSchemas :: [SchemaWithURI schema] - subSchemas = - (\a -> SchemaWithURI a (updateResolutionScope mUri (_fiId info schema))) - <$> uncurry (<>) (_fiEmbedded info schema) diff --git a/src/Data/JsonSchema/Types.hs b/src/Data/JsonSchema/Types.hs deleted file mode 100644 --- a/src/Data/JsonSchema/Types.hs +++ /dev/null @@ -1,36 +0,0 @@ - -module Data.JsonSchema.Types where - -import Import - -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 - -> [err] -validate spec schema v = - (\val -> _validate val schema v) =<< _unSpec spec - --- | 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 deleted file mode 100644 --- a/src/Data/Validator/Draft4.hs +++ /dev/null @@ -1,242 +0,0 @@ --- | Turn the validation functions into actual 'Validator's. - -module Data.Validator.Draft4 - ( module Data.Validator.Draft4 - , module Export - ) where - -import Import - -import qualified Data.HashMap.Strict as HM -import qualified Data.List.NonEmpty as NE -import Data.Maybe (catMaybes, maybe, maybeToList) -import Data.Text (Text) - -import Data.Validator.Draft4.Any as Export -import Data.Validator.Draft4.Array as Export -import Data.Validator.Draft4.Number as Export -import Data.Validator.Draft4.Object as Export -import Data.Validator.Draft4.String as Export -import Data.Validator.Types (Validator(..)) -import Data.Validator.Utils (fromJSONEither) - --- | For internal use. --- --- Take a validation function, a possibly existing validator, and some data. --- If the validator is exists and can validate the type of data we have, --- attempt to do so and return any failures. -run :: FromJSON b => (a -> b -> Maybe c) -> Maybe a -> Value -> [c] -run _ Nothing _ = mempty -run f (Just a) b = - case fromJSONEither b of - Left _ -> mempty - Right c -> maybeToList (f a c) - --- | For internal use. -noEmbedded :: a -> ([b], [b]) -noEmbedded = const (mempty, mempty) - --------------------------------------------------- --- * Numbers --------------------------------------------------- - -multipleOfValidator :: Validator a (Maybe MultipleOf) MultipleOfInvalid -multipleOfValidator = Validator noEmbedded (run multipleOfVal) - -maximumValidator :: Validator a (Maybe Maximum) MaximumInvalid -maximumValidator = Validator noEmbedded (run maximumVal) - -minimumValidator :: Validator a (Maybe Minimum) MinimumInvalid -minimumValidator = Validator noEmbedded (run minimumVal) - --------------------------------------------------- --- * Strings --------------------------------------------------- - -maxLengthValidator :: Validator a (Maybe MaxLength) MaxLengthInvalid -maxLengthValidator = Validator noEmbedded (run maxLengthVal) - -minLengthValidator :: Validator a (Maybe MinLength) MinLengthInvalid -minLengthValidator = Validator noEmbedded (run minLengthVal) - -patternValidator :: Validator a (Maybe PatternValidator) PatternInvalid -patternValidator = Validator noEmbedded (run patternVal) - --------------------------------------------------- --- * Arrays --------------------------------------------------- - -maxItemsValidator :: Validator a (Maybe MaxItems) MaxItemsInvalid -maxItemsValidator = Validator noEmbedded (run maxItemsVal) - -minItemsValidator :: Validator a (Maybe MinItems) MinItemsInvalid -minItemsValidator = Validator noEmbedded (run minItemsVal) - -uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid -uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal) - -itemsRelatedValidator - :: (schema -> Value -> [err]) - -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err) -itemsRelatedValidator f = - Validator - (\a -> ( mempty - , case _irItems a of - Just (ItemsObject b) -> pure b - Just (ItemsArray cs) -> cs - Nothing -> mempty - <> case _irAdditional a of - Just (AdditionalObject b) -> pure b - _ -> mempty - )) - (\a b -> case fromJSONEither b of - Left _ -> mempty - Right c -> itemsRelatedVal f a c) - --------------------------------------------------- --- * Objects --------------------------------------------------- - -maxPropertiesValidator - :: Validator - a - (Maybe MaxProperties) - MaxPropertiesInvalid -maxPropertiesValidator = Validator noEmbedded (run maxPropertiesVal) - -minPropertiesValidator - :: Validator - a - (Maybe MinProperties) - MinPropertiesInvalid -minPropertiesValidator = Validator noEmbedded (run minPropertiesVal) - -requiredValidator :: Validator a (Maybe Required) () -requiredValidator = Validator noEmbedded (run requiredVal) - -dependenciesValidator - :: (schema -> Value -> [err]) - -> Validator - schema - (Maybe (DependenciesValidator schema)) - (DependenciesInvalid err) -dependenciesValidator f = - Validator - (maybe mempty ( (\a -> (mempty, a)) - . catMaybes . fmap checkDependency - . HM.elems . _unDependenciesValidator - )) - (run (dependenciesVal f)) - where - checkDependency :: Dependency schema -> Maybe schema - checkDependency (PropertyDependency _) = Nothing - checkDependency (SchemaDependency s) = Just s - -propertiesRelatedValidator - :: (schema -> Value -> [err]) - -> Validator - schema - (PropertiesRelated schema) - (PropertiesRelatedInvalid err) -propertiesRelatedValidator f = - Validator - (\a -> ( mempty - , HM.elems (fromMaybe mempty (_propProperties a)) - <> HM.elems (fromMaybe mempty (_propPattern a)) - <> case _propAdditional a of - Just (AdditionalPropertiesObject b) -> [b] - _ -> mempty - )) - (\a b -> case fromJSONEither b of - Left _ -> mempty - Right c -> maybeToList (propertiesRelatedVal f a c)) - -newtype Definitions schema - = Definitions { _unDefinitions :: HashMap Text schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (Definitions schema) where - parseJSON = withObject "Definitions" $ \o -> - Definitions <$> o .: "definitions" - --- TODO: Add tests to the language agnostic test suite to --- make sure these schemas are embedded correctly --- (and do so for @"additionalItems"@ as well). -definitionsEmbedded - :: Validator - schema - (Maybe (Definitions schema)) - err -definitionsEmbedded = - Validator - (\a -> case a of - Just (Definitions b) -> (mempty, HM.elems b) - Nothing -> (mempty, mempty)) - (const (const mempty)) - --------------------------------------------------- --- * Any --------------------------------------------------- - -refValidator - :: (FromJSON schema, ToJSON schema) - => VisitedSchemas - -> Maybe Text - -> (Maybe Text -> Maybe schema) - -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err]) - -> Validator a (Maybe Ref) (RefInvalid err) -refValidator visited scope getRef f = - Validator - noEmbedded - (run (refVal visited scope getRef f)) - -enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid -enumValidator = Validator noEmbedded (run enumVal) - -typeValidator :: Validator a (Maybe TypeContext) TypeValidatorInvalid -typeValidator = Validator noEmbedded (run typeVal) - -allOfValidator - :: (schema -> Value -> [err]) - -> Validator schema (Maybe (AllOf schema)) (AllOfInvalid err) -allOfValidator f = - Validator - (\a -> case a of - Just (AllOf b) -> (NE.toList b, mempty) - Nothing -> (mempty, mempty)) - (run (allOfVal f)) - -anyOfValidator - :: (schema -> Value -> [err]) - -> Validator schema (Maybe (AnyOf schema)) (AnyOfInvalid err) -anyOfValidator f = - Validator - (\a -> case a of - Just (AnyOf b) -> (NE.toList b, mempty) - Nothing -> (mempty, mempty)) - (run (anyOfVal f)) - -oneOfValidator - :: ToJSON schema - => (schema -> Value -> [err]) - -> Validator schema (Maybe (OneOf schema)) (OneOfInvalid err) -oneOfValidator f = - Validator - (\a -> case a of - Just (OneOf b) -> (NE.toList b, mempty) - Nothing -> (mempty, mempty)) - (run (oneOfVal f)) - -notValidator - :: ToJSON schema - => (schema -> Value -> [err]) - -> Validator - schema - (Maybe (NotValidator schema)) - NotValidatorInvalid -notValidator f = - Validator - (\a -> case a of - Just (NotValidator b) -> (pure b, mempty) - Nothing -> (mempty, mempty)) - (run (notVal f)) diff --git a/src/Data/Validator/Draft4/Any.hs b/src/Data/Validator/Draft4/Any.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Any.hs +++ /dev/null @@ -1,350 +0,0 @@ - -module Data.Validator.Draft4.Any where - -import Import - -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.List.NonEmpty as NE -import qualified Data.Scientific as SCI -import Data.Semigroup (Semigroup) -- for older GHCs -import Data.Set (Set) -import qualified Data.Set as S -import qualified JSONPointer as JP - -import qualified Data.Validator.Utils as UT -import Data.Validator.Reference (URIBaseAndFragment, - resolveFragment, resolveReference) - --------------------------------------------------- --- * $ref --------------------------------------------------- - -newtype Ref - = Ref { _unRef :: Text } - deriving (Eq, Show) - -instance FromJSON Ref where - parseJSON = withObject "Ref" $ \o -> - Ref <$> o .: "$ref" - -data RefInvalid err - = RefResolution Text - -- ^ Indicates a reference that failed to resolve. - -- - -- NOTE: The language agnostic test suite doesn't specify if this should - -- cause a validation error or should allow data to pass. We choose to - -- return a validation error. - -- - -- Also note that ideally we would enforce in the type system that any - -- failing references be dealt with before valididation. Then this could - -- be removed entirely. - | RefPointerResolution Text - | RefLoop Text VisitedSchemas URIBaseAndFragment - | RefInvalid Text Value (NonEmpty err) - -- ^ 'Text' is the URI and 'Value' is the linked schema. - deriving (Eq, Show) - -newtype VisitedSchemas - = VisitedSchemas { _unVisited :: [URIBaseAndFragment] } - deriving (Eq, Show, Semigroup, Monoid) - -refVal - :: forall err schema. (FromJSON schema, ToJSON schema) - => VisitedSchemas - -> Maybe Text - -> (Maybe Text -> Maybe schema) - -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err]) - -> Ref - -> Value - -> Maybe (RefInvalid err) -refVal visited scope getRef f (Ref reference) x - | (mURI, mFragment) `elem` _unVisited visited = - Just (RefLoop reference visited (mURI, mFragment)) - | otherwise = - case getRef mURI of - Nothing -> Just (RefResolution reference) - Just schema -> - case resolveFragment mFragment schema of - Nothing -> Just (RefPointerResolution reference) - Just s -> - let newVisited = (VisitedSchemas [(mURI, mFragment)] - <> visited) - errs = f newVisited mURI s x - in RefInvalid reference (toJSON schema) - <$> NE.nonEmpty errs - where - (mURI, mFragment) = resolveReference scope reference - --------------------------------------------------- --- * enum --------------------------------------------------- - --- | From the spec: --- --- --- > The value of this keyword MUST be an array. --- > This array MUST have at least one element. --- > Elements in the array MUST be unique. --- --- NOTE: We don't enforce the uniqueness constraint in the haskell code, --- but we do in the 'FromJSON' instance. -newtype EnumValidator - = EnumValidator { _unEnumValidator :: NonEmpty Value } - -- Given a choice, we'd prefer to enforce uniqueness through the type - -- system over having at least one element. To use a 'Set' though we'd - -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values) - -- and we'd rather not make users mess with 'OrdValue'. - deriving (Eq, Show) - -instance FromJSON EnumValidator where - parseJSON = withObject "EnumValidator" $ \o -> - EnumValidator <$> o .: "enum" - -instance Arbitrary EnumValidator where - arbitrary = do - xs <- (fmap.fmap) UT._unArbitraryValue arbitrary - case NE.nonEmpty (toUnique xs) of - Nothing -> EnumValidator . pure . UT._unArbitraryValue <$> arbitrary - Just ne -> pure (EnumValidator ne) - where - toUnique :: [Value] -> [Value] - toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue - -data EnumInvalid - = EnumInvalid EnumValidator Value - deriving (Eq, Show) - -enumVal :: EnumValidator -> Value -> Maybe EnumInvalid -enumVal a@(EnumValidator vs) x - | not (UT.allUniqueValues' vs) = Nothing - | x `elem` vs = Nothing - | otherwise = Just $ EnumInvalid a x - --------------------------------------------------- --- * type --------------------------------------------------- - --- | This is separate from 'TypeValidator' so that 'TypeValidator' can --- be used to write 'Data.JsonSchema.Draft4.Schema.Schema' without --- messing up the 'FromJSON' instance of that data type. -newtype TypeContext - = TypeContext { _unTypeContext :: TypeValidator } - deriving (Eq, Show) - -instance FromJSON TypeContext where - parseJSON = withObject "TypeContext" $ \o -> - TypeContext <$> o .: "type" - -data TypeValidator - = TypeValidatorString Text - | TypeValidatorArray (Set Text) - deriving (Eq, Show) - -instance FromJSON TypeValidator where - parseJSON v = fmap TypeValidatorString (parseJSON v) - <|> fmap TypeValidatorArray (parseJSON v) - -instance ToJSON TypeValidator where - toJSON (TypeValidatorString t) = toJSON t - toJSON (TypeValidatorArray ts) = toJSON ts - -instance Arbitrary TypeValidator where - arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText - , TypeValidatorArray <$> UT.arbitrarySetOfText - ] - -data TypeValidatorInvalid - = TypeValidatorInvalid TypeValidator Value - deriving (Eq, Show) - -typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid -typeVal (TypeContext tv) x - | S.null matches = Just (TypeValidatorInvalid tv x) - | otherwise = Nothing - where - -- There can be more than one match because a 'Value' can be both a - -- @"number"@ and an @"integer"@. - matches :: Set Text - matches = S.intersection okTypes (setFromTypeValidator tv) - - okTypes :: Set Text - okTypes = - case x of - Null -> S.singleton "null" - (Array _) -> S.singleton "array" - (Bool _) -> S.singleton "boolean" - (Object _) -> S.singleton "object" - (String _) -> S.singleton "string" - (Number y) -> - if SCI.isInteger y - then S.fromList ["number", "integer"] - else S.singleton "number" - --- | Internal. -setFromTypeValidator :: TypeValidator -> Set Text -setFromTypeValidator (TypeValidatorString t) = S.singleton t -setFromTypeValidator (TypeValidatorArray ts) = ts - --------------------------------------------------- --- * allOf --------------------------------------------------- - -newtype AllOf schema - = AllOf { _unAllOf :: NonEmpty schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AllOf schema) where - parseJSON = withObject "AllOf" $ \o -> - AllOf <$> o .: "allOf" - -newtype AllOfInvalid err - = AllOfInvalid (NonEmpty (JP.Index, NonEmpty err)) - deriving (Eq, Show) - -allOfVal - :: forall err schema. - (schema -> Value -> [err]) - -> AllOf schema - -> Value - -> Maybe (AllOfInvalid err) -allOfVal f (AllOf subSchemas) x = AllOfInvalid <$> NE.nonEmpty failures - where - perhapsFailures :: [(JP.Index, [err])] - perhapsFailures = zip (JP.Index <$> [0..]) - (flip f x <$> NE.toList subSchemas) - - failures :: [(JP.Index, NonEmpty err)] - failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures - --------------------------------------------------- --- * anyOf --------------------------------------------------- - -newtype AnyOf schema - = AnyOf { _unAnyOf :: NonEmpty schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AnyOf schema) where - parseJSON = withObject "AnyOf" $ \o -> - AnyOf <$> o .: "anyOf" - -newtype AnyOfInvalid err - = AnyOfInvalid (NonEmpty (JP.Index, NonEmpty err)) - deriving (Eq, Show) - -anyOfVal - :: forall err schema. - (schema -> Value -> [err]) - -> AnyOf schema - -> Value - -> Maybe (AnyOfInvalid err) -anyOfVal f (AnyOf subSchemas) x - -- Replace with @null@ once we drop GHC 7.8: - | any (((==) 0 . length) . snd) perhapsFailures = Nothing - | otherwise = AnyOfInvalid <$> NE.nonEmpty failures - where - perhapsFailures :: [(JP.Index, [err])] - perhapsFailures = zip (JP.Index <$> [0..]) - (flip f x <$> NE.toList subSchemas) - - failures :: [(JP.Index, NonEmpty err)] - failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures - --------------------------------------------------- --- * oneOf --------------------------------------------------- - -newtype OneOf schema - = OneOf { _unOneOf :: NonEmpty schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (OneOf schema) where - parseJSON = withObject "OneOf" $ \o -> - OneOf <$> o .: "oneOf" - -data OneOfInvalid err - = TooManySuccesses (NonEmpty (JP.Index, Value)) Value - -- ^ The NonEmpty lists contains tuples whose contents - -- are the index of a schema that validated the data - -- and the contents of that schema. - | NoSuccesses (NonEmpty (JP.Index, NonEmpty err)) Value - -- ^ The NonEmpty lists contains tuples whose contents - -- are the index of a schema that failed to validate the data - -- and the failures it produced. - deriving (Eq, Show) - -oneOfVal - :: forall err schema. ToJSON schema - => (schema -> Value -> [err]) - -> OneOf schema - -> Value - -> Maybe (OneOfInvalid err) -oneOfVal f (OneOf (firstSubSchema :| otherSubSchemas)) x = - -- Producing the NonEmpty lists needed by the error constructors - -- is a little tricky. If we had a partition function like this - -- it might help: - -- @ - -- (a -> Either b c) -> NonEmpty a -> Either (NonEmpty b, [c]) - -- ([b], NonEmpty c) - -- @ - case (firstSuccess, otherSuccesses) of - (Right _, Nothing) -> Nothing - (Right a, Just successes) -> Just (TooManySuccesses - (a NE.<| successes) x) - (Left e, Nothing) -> Just (NoSuccesses (e :| otherFailures) x) - (Left _, Just (_ :| [])) -> Nothing - (Left _, Just successes) -> Just (TooManySuccesses successes x) - where - firstSuccess :: Either (JP.Index, NonEmpty err) (JP.Index, Value) - firstSuccess = - case NE.nonEmpty (f firstSubSchema x) of - Nothing -> Right (JP.Index 0, toJSON firstSubSchema) - Just errs -> Left (JP.Index 0, errs) - - otherPerhapsFailures :: [(JP.Index, Value, [err])] - otherPerhapsFailures = - zipWith - (\index schema -> (index, toJSON schema, f schema x)) - (JP.Index <$> [0..]) - otherSubSchemas - - otherSuccesses :: Maybe (NonEmpty (JP.Index, Value)) - otherSuccesses = NE.nonEmpty - $ mapMaybe (\(index,val,errs) -> - case errs of - [] -> Just (index,val) - _ -> Nothing - ) otherPerhapsFailures - - otherFailures :: [(JP.Index, NonEmpty err)] - otherFailures = mapMaybe (traverse NE.nonEmpty . mid) otherPerhapsFailures - - mid :: (a,b,c) -> (a,c) - mid (a,_,c) = (a,c) - --------------------------------------------------- --- * not --------------------------------------------------- - -newtype NotValidator schema - = NotValidator { _unNotValidator :: schema } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (NotValidator schema) where - parseJSON = withObject "NotValidator" $ \o -> - NotValidator <$> o .: "not" - -data NotValidatorInvalid - = NotValidatorInvalid Value Value - deriving (Eq, Show) - -notVal - :: ToJSON schema => - (schema -> Value -> [err]) - -> NotValidator schema - -> Value - -> Maybe NotValidatorInvalid -notVal f (NotValidator schema) x = - case f schema x of - [] -> Just (NotValidatorInvalid (toJSON schema) x) - _ -> Nothing diff --git a/src/Data/Validator/Draft4/Array.hs b/src/Data/Validator/Draft4/Array.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Array.hs +++ /dev/null @@ -1,224 +0,0 @@ - -module Data.Validator.Draft4.Array where - -import Import - -import qualified Data.List.NonEmpty as NE -import qualified Data.Vector as V -import qualified JSONPointer as JP - -import Data.Validator.Utils (allUniqueValues) - --------------------------------------------------- --- * maxItems --------------------------------------------------- - -newtype MaxItems - = MaxItems { _unMaxItems :: Int } - deriving (Eq, Show) - -instance FromJSON MaxItems where - parseJSON = withObject "MaxItems" $ \o -> - MaxItems <$> o .: "maxItems" - -data MaxItemsInvalid - = MaxItemsInvalid MaxItems (Vector Value) - deriving (Eq, Show) - --- | The spec requires @"maxItems"@ to be non-negative. -maxItemsVal :: MaxItems -> Vector Value -> Maybe MaxItemsInvalid -maxItemsVal a@(MaxItems n) xs - | n < 0 = Nothing - | V.length xs > n = Just (MaxItemsInvalid a xs) - | otherwise = Nothing - --------------------------------------------------- --- * minItems --------------------------------------------------- - -newtype MinItems - = MinItems { _unMinItems :: Int } - deriving (Eq, Show) - -instance FromJSON MinItems where - parseJSON = withObject "MinItems" $ \o -> - MinItems <$> o .: "minItems" - -data MinItemsInvalid - = MinItemsInvalid MinItems (Vector Value) - deriving (Eq, Show) - --- | The spec requires @"minItems"@ to be non-negative. -minItemsVal :: MinItems -> Vector Value -> Maybe MinItemsInvalid -minItemsVal a@(MinItems n) xs - | n < 0 = Nothing - | V.length xs < n = Just (MinItemsInvalid a xs) - | otherwise = Nothing - --------------------------------------------------- --- * uniqueItems --------------------------------------------------- - -newtype UniqueItems - = UniqueItems { _unUniqueItems :: Bool } - deriving (Eq, Show) - -instance FromJSON UniqueItems where - parseJSON = withObject "UniqueItems" $ \o -> - UniqueItems <$> o .: "uniqueItems" - -data UniqueItemsInvalid - = UniqueItemsInvalid (Vector Value) - deriving (Eq, Show) - -uniqueItemsVal :: UniqueItems -> Vector Value -> Maybe UniqueItemsInvalid -uniqueItemsVal (UniqueItems True) xs - | allUniqueValues xs = Nothing - | otherwise = Just (UniqueItemsInvalid xs) -uniqueItemsVal (UniqueItems False) _ = Nothing - --------------------------------------------------- --- * items --------------------------------------------------- - -data ItemsRelated schema = ItemsRelated - { _irItems :: Maybe (Items schema) - , _irAdditional :: Maybe (AdditionalItems schema) - } deriving (Eq, Show) - -instance FromJSON schema => FromJSON (ItemsRelated schema) where - parseJSON = withObject "ItemsRelated" $ \o -> ItemsRelated - <$> o .:! "items" - <*> o .:! "additionalItems" - -emptyItems :: ItemsRelated schema -emptyItems = ItemsRelated - { _irItems = Nothing - , _irAdditional = Nothing - } - -data Items schema - = ItemsObject schema - | ItemsArray [schema] - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (Items schema) where - parseJSON v = fmap ItemsObject (parseJSON v) - <|> fmap ItemsArray (parseJSON v) - -instance ToJSON schema => ToJSON (Items schema) where - toJSON (ItemsObject hm) = toJSON hm - toJSON (ItemsArray schemas) = toJSON schemas - -instance Arbitrary schema => Arbitrary (Items schema) where - arbitrary = oneof [ ItemsObject <$> arbitrary - , ItemsArray <$> arbitrary - ] - -data ItemsRelatedInvalid err - = IRInvalidItems (ItemsInvalid err) - | IRInvalidAdditional (AdditionalItemsInvalid err) - deriving (Eq, Show) - -data ItemsInvalid err - = ItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err)) - | ItemsArrayInvalid (NonEmpty (JP.Index, NonEmpty err)) - deriving (Eq, Show) - --- | @"additionalItems"@ only matters if @"items"@ exists --- and is a JSON Array. -itemsRelatedVal - :: forall err schema. - (schema -> Value -> [err]) - -> ItemsRelated schema - -> Vector Value - -> [ItemsRelatedInvalid err] -- NOTE: 'Data.These' would help here. -itemsRelatedVal f a xs = - let (itemsFailure, remaining) = case _irItems a of - Nothing -> (Nothing, mempty) - Just b -> itemsVal f b xs - additionalFailure = (\b -> additionalItemsVal f b remaining) - =<< _irAdditional a - in catMaybes [ IRInvalidItems <$> itemsFailure - , IRInvalidAdditional <$> additionalFailure - ] - --- | Internal. --- --- This is because 'itemsRelated' handles @"items"@ validation. -itemsVal - :: forall err schema. - (schema -> Value -> [err]) - -> Items schema - -> Vector Value - -> (Maybe (ItemsInvalid err), [(JP.Index, Value)]) - -- ^ The second item in the tuple is the elements of the original - -- JSON Array still remaining to be checked by @"additionalItems"@. -itemsVal f a xs = - case a of - ItemsObject subSchema -> - case NE.nonEmpty (mapMaybe (validateElem subSchema) indexed) of - Nothing -> (Nothing, mempty) - Just errs -> (Just (ItemsObjectInvalid errs), mempty) - ItemsArray subSchemas -> - let remaining = drop (length subSchemas) indexed - res = catMaybes (zipWith validateElem subSchemas indexed) - in case NE.nonEmpty res of - Nothing -> (Nothing, remaining) - Just errs -> (Just (ItemsArrayInvalid errs), remaining) - where - indexed :: [(JP.Index, Value)] - indexed = zip (JP.Index <$> [0..]) (V.toList xs) - - validateElem - :: schema - -> (JP.Index, Value) - -> Maybe (JP.Index, NonEmpty err) - validateElem schema (index,x) = (index,) <$> NE.nonEmpty (f schema x) - --------------------------------------------------- --- * additionalItems --------------------------------------------------- - -data AdditionalItems schema - = AdditionalBool Bool - | AdditionalObject schema - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AdditionalItems schema) where - parseJSON v = fmap AdditionalBool (parseJSON v) - <|> fmap AdditionalObject (parseJSON v) - -instance ToJSON schema => ToJSON (AdditionalItems schema) where - toJSON (AdditionalBool b) = toJSON b - toJSON (AdditionalObject hm) = toJSON hm - -instance Arbitrary schema => Arbitrary (AdditionalItems schema) where - arbitrary = oneof [ AdditionalBool <$> arbitrary - , AdditionalObject <$> arbitrary - ] - -data AdditionalItemsInvalid err - = AdditionalItemsBoolInvalid (NonEmpty (JP.Index, Value)) - | AdditionalItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err)) - deriving (Eq, Show) - --- | Internal. --- --- This is because 'itemsRelated' handles @"additionalItems"@ validation. -additionalItemsVal - :: forall err schema. - (schema -> Value -> [err]) - -> AdditionalItems schema - -> [(JP.Index, Value)] - -- ^ The elements remaining to validate after the ones covered by - -- @"items"@ have been removed. - -> Maybe (AdditionalItemsInvalid err) -additionalItemsVal _ (AdditionalBool True) _ = Nothing -additionalItemsVal _ (AdditionalBool False) xs = - AdditionalItemsBoolInvalid <$> NE.nonEmpty xs -additionalItemsVal f (AdditionalObject subSchema) xs = - let res = mapMaybe - (\(index,x) -> (index,) <$> NE.nonEmpty (f subSchema x)) - xs - in AdditionalItemsObjectInvalid <$> NE.nonEmpty res diff --git a/src/Data/Validator/Draft4/Number.hs b/src/Data/Validator/Draft4/Number.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Number.hs +++ /dev/null @@ -1,84 +0,0 @@ - -module Data.Validator.Draft4.Number where - -import Import - -import Data.Fixed (mod') -import Data.Scientific (Scientific) - --------------------------------------------------- --- * multipleOf --------------------------------------------------- - -newtype MultipleOf - = MultipleOf { _unMultipleOf :: Scientific } - deriving (Eq, Show) - -instance FromJSON MultipleOf where - parseJSON = withObject "MultipleOf" $ \o -> - MultipleOf <$> o .: "multipleOf" - -data MultipleOfInvalid - = MultipleOfInvalid MultipleOf Scientific - deriving (Eq, Show) - --- | The spec requires @"multipleOf"@ to be positive. -multipleOfVal :: MultipleOf -> Scientific -> Maybe MultipleOfInvalid -multipleOfVal a@(MultipleOf n) x - | n <= 0 = Nothing - | x `mod'` n /= 0 = Just (MultipleOfInvalid a x) - | otherwise = Nothing - --------------------------------------------------- --- * maximum --------------------------------------------------- - -data Maximum = Maximum - { _maximumExclusive :: Bool - , _maximumValue :: Scientific - } deriving (Eq, Show) - -instance FromJSON Maximum where - parseJSON = withObject "Maximum" $ \o -> Maximum - <$> o .:! "exclusiveMaximum" .!= False - <*> o .: "maximum" - -data MaximumInvalid - = MaximumInvalid Maximum Scientific - deriving (Eq, Show) - -maximumVal - :: Maximum - -> Scientific - -> Maybe MaximumInvalid -maximumVal a@(Maximum exclusive n) x - | exclusive && x >= n = Just (MaximumInvalid a x) - | x > n = Just (MaximumInvalid a x) - | otherwise = Nothing - --------------------------------------------------- --- * minimum --------------------------------------------------- - -data Minimum = Minimum - { _minimumExclusive :: Bool - , _minimumValue :: Scientific - } deriving (Eq, Show) - -instance FromJSON Minimum where - parseJSON = withObject "Minimum" $ \o -> Minimum - <$> o .:! "exclusiveMinimum" .!= False - <*> o .: "minimum" - -data MinimumInvalid - = MinimumInvalid Minimum Scientific - deriving (Eq, Show) - -minimumVal - :: Minimum - -> Scientific - -> Maybe MinimumInvalid -minimumVal a@(Minimum exclusive n) x - | exclusive && x <= n = Just (MinimumInvalid a x) - | x < n = Just (MinimumInvalid a x) - | otherwise = Nothing diff --git a/src/Data/Validator/Draft4/Object.hs b/src/Data/Validator/Draft4/Object.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Object.hs +++ /dev/null @@ -1,179 +0,0 @@ - -module Data.Validator.Draft4.Object - ( module Data.Validator.Draft4.Object - , module Data.Validator.Draft4.Object.Properties - ) where - -import Import - -import qualified Data.HashMap.Strict as HM -import qualified Data.List.NonEmpty as NE -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Text as T - -import Data.Validator.Draft4.Object.Properties -import Data.Validator.Utils - --------------------------------------------------- --- * maxProperties --------------------------------------------------- - -newtype MaxProperties - = MaxProperties { _unMaxProperties :: Int } - deriving (Eq, Show) - -instance FromJSON MaxProperties where - parseJSON = withObject "MaxProperties" $ \o -> - MaxProperties <$> o .: "maxProperties" - -data MaxPropertiesInvalid - = MaxPropertiesInvalid MaxProperties (HashMap Text Value) - deriving (Eq, Show) - --- | The spec requires @"maxProperties"@ to be non-negative. -maxPropertiesVal - :: MaxProperties - -> HashMap Text Value - -> Maybe MaxPropertiesInvalid -maxPropertiesVal a@(MaxProperties n) x - | n < 0 = Nothing - | HM.size x > n = Just (MaxPropertiesInvalid a x) - | otherwise = Nothing - --------------------------------------------------- --- * minProperties --------------------------------------------------- - -newtype MinProperties - = MinProperties { _unMinProperties :: Int } - deriving (Eq, Show) - -instance FromJSON MinProperties where - parseJSON = withObject "MinProperties" $ \o -> - MinProperties <$> o .: "minProperties" - -data MinPropertiesInvalid - = MinPropertiesInvalid MinProperties (HashMap Text Value) - deriving (Eq, Show) - --- | The spec requires @"minProperties"@ to be non-negative. -minPropertiesVal - :: MinProperties - -> HashMap Text Value - -> Maybe MinPropertiesInvalid -minPropertiesVal a@(MinProperties n) x - | n < 0 = Nothing - | HM.size x < n = Just (MinPropertiesInvalid a x) - | otherwise = Nothing - --------------------------------------------------- --- * required --------------------------------------------------- - --- | From the spec: --- --- > The value of this keyword MUST be an array. --- > This array MUST have at least one element. --- > Elements of this array MUST be strings, and MUST be unique. -newtype Required - = Required { _unRequired :: Set Text } - deriving (Eq, Show) - -instance FromJSON Required where - parseJSON = withObject "Required" $ \o -> - Required <$> o .: "required" - -instance Arbitrary Required where - arbitrary = do - x <- arbitraryText -- Guarantee at least one element. - xs <- (fmap.fmap) T.pack arbitrary - pure . Required . S.fromList $ x:xs - -requiredVal :: Required -> HashMap Text Value -> Maybe () -requiredVal (Required ts) x - -- NOTE: When we no longer need to support GHCs before 7.10 - -- we can use null from Prelude throughout the library - -- instead of specialized versions. - | S.null ts = Nothing - | HM.null (HM.difference hm x) = Nothing - | otherwise = Just () -- TODO - where - hm :: HashMap Text Bool - hm = foldl (\b a -> HM.insert a True b) mempty ts - --------------------------------------------------- --- * dependencies --------------------------------------------------- - -newtype DependenciesValidator schema - = DependenciesValidator - { _unDependenciesValidator :: HashMap Text (Dependency schema) } - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (DependenciesValidator schema) where - parseJSON = withObject "DependenciesValidator" $ \o -> - DependenciesValidator <$> o .: "dependencies" - -data Dependency schema - = SchemaDependency schema - | PropertyDependency (Set Text) - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (Dependency schema) where - parseJSON v = fmap SchemaDependency (parseJSON v) - <|> fmap PropertyDependency (parseJSON v) - -instance ToJSON schema => ToJSON (Dependency schema) where - toJSON (SchemaDependency schema) = toJSON schema - toJSON (PropertyDependency ts) = toJSON ts - -instance Arbitrary schema => Arbitrary (Dependency schema) where - arbitrary = oneof [ SchemaDependency <$> arbitrary - , PropertyDependency <$> arbitrarySetOfText - ] - -data DependencyMemberInvalid err - = SchemaDepInvalid (NonEmpty err) - | PropertyDepInvalid (Set Text) (HashMap Text Value) - deriving (Eq, Show) - -data DependenciesInvalid err - = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err)) - deriving (Eq, Show) - --- | From the spec: --- --- --- > This keyword's value MUST be an object. --- > Each value of this object MUST be either an object or an array. --- > --- > If the value is an object, it MUST be a valid JSON Schema. --- > This is called a schema dependency. --- > --- > If the value is an array, it MUST have at least one element. --- > Each element MUST be a string, and elements in the array MUST be unique. --- > This is called a property dependency. -dependenciesVal - :: forall err schema. - (schema -> Value -> [err]) - -> DependenciesValidator schema - -> HashMap Text Value - -> Maybe (DependenciesInvalid err) -dependenciesVal f (DependenciesValidator hm) x = - let res = HM.mapMaybeWithKey g hm - in if HM.null res - then Nothing - else Just (DependenciesInvalid res) - where - g :: Text -> Dependency schema -> Maybe (DependencyMemberInvalid err) - g k (SchemaDependency schema) - | HM.member k x = SchemaDepInvalid - <$> NE.nonEmpty (f schema (Object x)) - | otherwise = Nothing - g k (PropertyDependency ts) - | HM.member k x && not allPresent = Just (PropertyDepInvalid ts x) - | otherwise = Nothing - where - allPresent :: Bool - allPresent = all (`HM.member` x) ts diff --git a/src/Data/Validator/Draft4/Object/Properties.hs b/src/Data/Validator/Draft4/Object/Properties.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/Object/Properties.hs +++ /dev/null @@ -1,209 +0,0 @@ - -module Data.Validator.Draft4.Object.Properties where - -import Import - -import qualified Data.Hashable as HA -import qualified Data.HashMap.Strict as HM -import qualified Data.List.NonEmpty as NE -import Data.Text.Encoding (encodeUtf8) -import qualified JSONPointer as JP -import qualified Text.Regex.PCRE.Heavy as RE - -data PropertiesRelated schema = PropertiesRelated - { _propProperties :: Maybe (HashMap Text schema) - , _propPattern :: Maybe (HashMap Text schema) - , _propAdditional :: Maybe (AdditionalProperties schema) - } deriving (Eq, Show) - -instance FromJSON schema => FromJSON (PropertiesRelated schema) where - parseJSON = withObject "PropertiesRelated" $ \o -> PropertiesRelated - <$> o .:! "properties" - <*> o .:! "patternProperties" - <*> o .:! "additionalProperties" - -emptyProperties :: PropertiesRelated schema -emptyProperties = PropertiesRelated - { _propProperties = Nothing - , _propPattern = Nothing - , _propAdditional = Nothing - } - -data AdditionalProperties schema - = AdditionalPropertiesBool Bool - | AdditionalPropertiesObject schema - deriving (Eq, Show) - -instance FromJSON schema => FromJSON (AdditionalProperties schema) where - parseJSON v = fmap AdditionalPropertiesBool (parseJSON v) - <|> fmap AdditionalPropertiesObject (parseJSON v) - -instance ToJSON schema => ToJSON (AdditionalProperties schema) where - toJSON (AdditionalPropertiesBool b) = toJSON b - toJSON (AdditionalPropertiesObject hm) = toJSON hm - -instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where - arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary - , AdditionalPropertiesObject <$> arbitrary - ] - --- | A glorified @type@ alias. -newtype Regex - = Regex { _unRegex :: Text } - deriving (Eq, Show, Generic) - -instance HA.Hashable Regex - --- NOTE: We'd like to enforce that at least one error exists here. -data PropertiesRelatedInvalid err = PropertiesRelatedInvalid - { _prInvalidProperties :: HashMap Text [err] - , _prInvalidPattern :: HashMap (Regex, JP.Key) [err] - , _prInvalidAdditional :: Maybe (APInvalid err) - } deriving (Eq, Show) - -data APInvalid err - = APBoolInvalid (HashMap Text Value) - | APObjectInvalid (HashMap Text (NonEmpty err)) - deriving (Eq, Show) - --- | First @"properties"@ and @"patternProperties"@ are run simultaneously --- on the data, then @"additionalProperties"@ is run on the remainder. -propertiesRelatedVal - :: forall err schema. - (schema -> Value -> [err]) - -> PropertiesRelated schema - -> HashMap Text Value - -> Maybe (PropertiesRelatedInvalid err) -propertiesRelatedVal f props x - | all null (HM.elems propFailures) - && all null (HM.elems patFailures) - && isNothing addFailures = Nothing - | otherwise = - Just PropertiesRelatedInvalid - { _prInvalidProperties = propFailures - , _prInvalidPattern = patFailures - , _prInvalidAdditional = addFailures - } - where - propertiesHm :: HashMap Text schema - propertiesHm = fromMaybe mempty (_propProperties props) - - patHm :: HashMap Text schema - patHm = fromMaybe mempty (_propPattern props) - - propAndUnmatched :: (HashMap Text [err], Remaining) - propAndUnmatched = ( HM.intersectionWith f propertiesHm x - , Remaining (HM.difference x propertiesHm) - ) - - (propFailures, propRemaining) = propAndUnmatched - - patAndUnmatched :: (HashMap (Regex, JP.Key) [err], Remaining) - patAndUnmatched = patternAndUnmatched f patHm x - - (patFailures, patRemaining) = patAndUnmatched - - finalRemaining :: Remaining - finalRemaining = Remaining (HM.intersection (_unRemaining patRemaining) - (_unRemaining propRemaining)) - - addFailures :: Maybe (APInvalid err) - addFailures = (\addProp -> additionalProperties f addProp finalRemaining) - =<< _propAdditional props - --- | Internal. -newtype Remaining - = Remaining { _unRemaining :: HashMap Text Value } - --- | Internal. -patternAndUnmatched - :: forall err schema. - (schema -> Value -> [err]) - -> HashMap Text schema - -> HashMap Text Value - -> (HashMap (Regex, JP.Key) [err], Remaining) -patternAndUnmatched f patPropertiesHm x = - (HM.foldlWithKey' runMatches mempty perhapsMatches, remaining) - where - -- @[(Regex, schema)]@ will have one item per match. - perhapsMatches :: HashMap Text ([(Regex, schema)], Value) - perhapsMatches = - HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x - where - matchingSchemas - :: HashMap Text schema - -> HashMap Text ([(Regex, schema)], Value) - -> Text - -> Value - -> HashMap Text ([(Regex, schema)], Value) - matchingSchemas subSchemas acc k v = - HM.insert k - (HM.foldlWithKey' (checkKey k) mempty subSchemas, v) - acc - - checkKey - :: Text - -> [(Regex, schema)] - -> Text - -> schema - -> [(Regex, schema)] - checkKey k acc r subSchema = - case RE.compileM (encodeUtf8 r) mempty of - Left _ -> acc - Right re -> if k RE.=~ re - then (Regex r, subSchema) : acc - else acc - - runMatches - :: HashMap (Regex, JP.Key) [err] - -> Text - -> ([(Regex, schema)], Value) - -> HashMap (Regex, JP.Key) [err] - runMatches acc k (matches,v) = - foldr runMatch acc matches - where - runMatch - :: (Regex, schema) - -> HashMap (Regex, JP.Key) [err] - -> HashMap (Regex, JP.Key) [err] - runMatch (r,schema) = HM.insert (r, JP.Key k) (f schema v) - - remaining :: Remaining - remaining = Remaining . fmap snd . HM.filter (null . fst) $ perhapsMatches - --- Internal. -additionalProperties - :: forall err schema. - (schema -> Value -> [err]) - -> AdditionalProperties schema - -> Remaining - -> Maybe (APInvalid err) -additionalProperties f a x = - case a of - AdditionalPropertiesBool b -> - APBoolInvalid <$> additionalPropertiesBool b x - AdditionalPropertiesObject b -> - APObjectInvalid <$> additionalPropertiesObject f b x - --- | Internal. -additionalPropertiesBool - :: Bool - -> Remaining - -> Maybe (HashMap Text Value) -additionalPropertiesBool True _ = Nothing -additionalPropertiesBool False (Remaining x) - | HM.size x > 0 = Just x - | otherwise = Nothing - --- | Internal. -additionalPropertiesObject - :: forall err schema. - (schema -> Value -> [err]) - -> schema - -> Remaining - -> Maybe (HashMap Text (NonEmpty err)) -additionalPropertiesObject f schema (Remaining x) = - let errs = HM.mapMaybe (NE.nonEmpty . f schema) x - in if HM.null errs - then Nothing - else Just errs diff --git a/src/Data/Validator/Draft4/String.hs b/src/Data/Validator/Draft4/String.hs deleted file mode 100644 --- a/src/Data/Validator/Draft4/String.hs +++ /dev/null @@ -1,79 +0,0 @@ - -module Data.Validator.Draft4.String where - -import Import - -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import qualified Text.Regex.PCRE.Heavy as RE - --------------------------------------------------- --- * maxLength --------------------------------------------------- - -newtype MaxLength - = MaxLength { _unMaxLength :: Int } - deriving (Eq, Show) - -instance FromJSON MaxLength where - parseJSON = withObject "MaxLength" $ \o -> - MaxLength <$> o .: "maxLength" - -data MaxLengthInvalid - = MaxLengthInvalid MaxLength Text - deriving (Eq, Show) - --- | The spec requires @"maxLength"@ to be non-negative. -maxLengthVal :: MaxLength -> Text -> Maybe MaxLengthInvalid -maxLengthVal a@(MaxLength n) x - | n <= 0 = Nothing - | T.length x > n = Just (MaxLengthInvalid a x) - | otherwise = Nothing - --------------------------------------------------- --- * minLength --------------------------------------------------- - -newtype MinLength - = MinLength { _unMinLength :: Int } - deriving (Eq, Show) - -instance FromJSON MinLength where - parseJSON = withObject "MinLength" $ \o -> - MinLength <$> o .: "minLength" - -data MinLengthInvalid - = MinLengthInvalid MinLength Text - deriving (Eq, Show) - --- | The spec requires @"minLength"@ to be non-negative. -minLengthVal :: MinLength -> Text -> Maybe MinLengthInvalid -minLengthVal a@(MinLength n) x - | n <= 0 = Nothing - | T.length x < n = Just (MinLengthInvalid a x) - | otherwise = Nothing - --------------------------------------------------- --- * pattern --------------------------------------------------- - -newtype PatternValidator - = PatternValidator { _unPatternValidator :: Text } - deriving (Eq, Show) - -instance FromJSON PatternValidator where - parseJSON = withObject "PatternValidator" $ \o -> - PatternValidator <$> o .: "pattern" - -data PatternInvalid - = PatternNotRegex -- TODO: let these pass successfully? - | PatternInvalid PatternValidator Text - deriving (Eq, Show) - -patternVal :: PatternValidator -> Text -> Maybe PatternInvalid -patternVal a@(PatternValidator t) x = - case RE.compileM (encodeUtf8 t) mempty of - Left _ -> Just PatternNotRegex - Right re -> if x RE.=~ re - then Nothing - else Just (PatternInvalid a x) diff --git a/src/Data/Validator/Reference.hs b/src/Data/Validator/Reference.hs deleted file mode 100644 --- a/src/Data/Validator/Reference.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | JSON Reference is described here: --- --- --- And is extended for JSON Schema here: --- - -module Data.Validator.Reference where - -import Import - -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified JSONPointer as JP -import Network.HTTP.Types.URI (urlDecode) -import System.FilePath ((), dropFileName) - --- | TODO: Replace these with actual URI data types. -type URIBase = Maybe Text -type URIBaseAndFragment = (Maybe Text, Maybe Text) - -updateResolutionScope :: URIBase -> Maybe Text -> URIBase -updateResolutionScope mScope idKeyword - | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t - | otherwise = mScope - -resolveReference :: URIBase -> Text -> URIBaseAndFragment -resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t - -resolveFragment - :: (FromJSON schema, ToJSON schema) - => Maybe Text - -> schema - -> Maybe schema -resolveFragment Nothing schema = Just schema -resolveFragment (Just pointer) schema = do - let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer - p <- either (const Nothing) Just (JP.unescape urlDecoded) - x <- either (const Nothing) Just (JP.resolve p (toJSON schema)) - case fromJSON x of - Error _ -> Nothing - Success schema' -> Just schema' - --------------------------------------------------- --- * Helpers --------------------------------------------------- - -isRemoteReference :: Text -> Bool -isRemoteReference = T.isInfixOf "://" - -baseAndFragment :: Text -> URIBaseAndFragment -baseAndFragment = f . T.splitOn "#" - where - f :: [Text] -> URIBaseAndFragment - f [x] = (g x, Nothing) - f [x,y] = (g x, g y) - f _ = (Nothing, Nothing) - - g "" = Nothing - g x = Just x - -resolveScopeAgainst :: Maybe Text -> Text -> Text -resolveScopeAgainst Nothing t = t -resolveScopeAgainst (Just scope) t - | isRemoteReference t = t - | otherwise = smartAppend - where - -- There shouldn't be a fragment at the end of a scope URI, - -- but just in case a user leaves one in we want to be sure - -- to cut it off before appending. - smartAppend :: Text - smartAppend = - case baseAndFragment scope of - (Just base,_) -> - case T.unpack t of - -- We want "/foo" and "#/bar" to combine into - -- "/foo#/bar" not "/foo/#/bar". - '#':_ -> base <> t - _ -> T.pack (dropFileName (T.unpack base) T.unpack t) - _ -> t diff --git a/src/Data/Validator/Types.hs b/src/Data/Validator/Types.hs deleted file mode 100644 --- a/src/Data/Validator/Types.hs +++ /dev/null @@ -1,23 +0,0 @@ - -module Data.Validator.Types where - -import Import - -import Data.Profunctor (Profunctor(..)) - -data Validator schema val err = Validator - { _embedded :: val -> ([schema], [schema]) - -- ^ The first list is embedded schemas that validate the same piece - -- of data this schema validates (such as schemas embedded in 'allOf'). - -- The second is embedded schemas that validate a subset of that data - -- (such as the schemas embedded in 'items'). - -- - -- This is done to allow static detection of loops, though this isn't - -- implemented yet (though the Draft4 code does do live loop detection - -- during validation). - , _validate :: val -> Value -> [err] - } deriving Functor - -instance Profunctor (Validator schema) where - lmap f (Validator a b) = Validator (lmap f a) (lmap f b) - rmap = fmap diff --git a/src/Data/Validator/Utils.hs b/src/Data/Validator/Utils.hs deleted file mode 100644 --- a/src/Data/Validator/Utils.hs +++ /dev/null @@ -1,135 +0,0 @@ - -module Data.Validator.Utils where - -import Import - -import Control.Monad (fail) -import qualified Data.HashMap.Strict as HM -import qualified Data.List.NonEmpty as NE -import Data.Scientific (Scientific, fromFloatDigits) -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Vector as V - --------------------------------------------------- --- * QuickCheck --------------------------------------------------- - -arbitraryText :: Gen Text -arbitraryText = T.pack <$> arbitrary - -arbitraryScientific :: Gen Scientific -arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary - -arbitraryPositiveScientific :: Gen Scientific -arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific) - . getPositive - <$> arbitrary - -newtype ArbitraryValue - = ArbitraryValue { _unArbitraryValue :: Value } - deriving (Eq, Show) - -instance Arbitrary ArbitraryValue where - arbitrary = ArbitraryValue <$> sized f - where - f :: Int -> Gen Value - f n | n <= 1 = oneof nonRecursive - | otherwise = oneof $ - fmap (Array . V.fromList) (traverse (const (f (n `div` 10))) - =<< (arbitrary :: Gen [()])) - : fmap (Object . HM.fromList) (traverse (const (g (n `div` 10))) - =<< (arbitrary :: Gen [()])) - : nonRecursive - - g :: Int -> Gen (Text, Value) - g n = (,) <$> arbitraryText <*> f n - - nonRecursive :: [Gen Value] - nonRecursive = - [ pure Null - , Bool <$> arbitrary - , String <$> arbitraryText - , Number <$> arbitraryScientific - ] - -arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a) -arbitraryHashMap = HM.fromList . fmap (first T.pack) <$> arbitrary - -arbitrarySetOfText :: Gen (Set Text) -arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary - -newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a } - -instance FromJSON a => FromJSON (NonEmpty' a) where - parseJSON v = do - xs <- parseJSON v - case NE.nonEmpty xs of - Nothing -> fail "Must have at least one item." - Just ne -> pure (NonEmpty' ne) - -instance ToJSON a => ToJSON (NonEmpty' a) where - toJSON = toJSON . NE.toList . _unNonEmpty' - -instance Arbitrary a => Arbitrary (NonEmpty' a) where - arbitrary = do - xs <- arbitrary - case NE.nonEmpty xs of - Nothing -> NonEmpty' . pure <$> arbitrary - Just ne -> pure (NonEmpty' ne) - --------------------------------------------------- --- * allUniqueValues --------------------------------------------------- - -allUniqueValues :: Vector Value -> Bool -allUniqueValues = allUnique . fmap OrdValue . V.toList - --- NOTE: When we no longer support GHC 7.8 we can generalize --- allUnique to work on any Foldable and remove this function. -allUniqueValues' :: NonEmpty Value -> Bool -allUniqueValues' = allUnique . fmap OrdValue . NE.toList - -allUnique :: (Ord a) => [a] -> Bool -allUnique xs = S.size (S.fromList xs) == length xs - --- | OrdValue's Ord instance needs benchmarking, but it allows us to --- use our 'allUnique' function instead of O(n^2) nub, so it's probably --- worth it. -newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq - -instance Ord OrdValue where - (OrdValue Null) `compare` (OrdValue Null) = EQ - (OrdValue Null) `compare` _ = LT - _ `compare` (OrdValue Null) = GT - - (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y - (OrdValue (Bool _)) `compare` _ = LT - _ `compare` (OrdValue (Bool _)) = GT - - (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y - (OrdValue (Number _)) `compare` _ = LT - _ `compare` (OrdValue (Number _)) = GT - - (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y - (OrdValue (String _)) `compare` _ = LT - _ `compare` (OrdValue (String _)) = GT - - (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) = - (OrdValue <$> xs) `compare` (OrdValue <$> ys) - (OrdValue (Array _)) `compare` _ = LT - _ `compare` (OrdValue (Array _)) = GT - - (OrdValue (Object x)) `compare` (OrdValue (Object y)) = - HM.toList (OrdValue <$> x) `compare` HM.toList (OrdValue <$> y) - --------------------------------------------------- --- * other --------------------------------------------------- - -fromJSONEither :: FromJSON a => Value -> Either Text a -fromJSONEither a = - case fromJSON a of - Error e -> Left (T.pack e) - Success b -> Right b diff --git a/src/JSONSchema/Draft4.hs b/src/JSONSchema/Draft4.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Draft4.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE TemplateHaskell #-} + +module JSONSchema.Draft4 + ( -- * Draft 4 Schema + SchemaWithURI(..) + , Schema(..) + , SC.emptySchema + + -- * One-step validation (getting references over HTTP) + , fetchHTTPAndValidate + , HTTPValidationFailure(..) + , FE.HTTPFailure(..) + , SchemaInvalid(..) + + -- * One-step validation (getting references from the filesystem) + , fetchFilesystemAndValidate + , FilesystemValidationFailure(..) + , FE.FilesystemFailure(..) + + -- * Validation failure + , Invalid(..) + , ValidatorFailure(..) + + -- * Fetching tools + , ReferencedSchemas(..) + , FE.URISchemaMap(..) + , referencesViaHTTP + , referencesViaFilesystem + + -- * Other Draft 4 things exported just in case + , metaSchema + , metaSchemaBytes + , schemaValidity + , referencesValidity + , checkSchema + , draft4FetchInfo + ) where + +import Import + +import Control.Arrow (left) +import qualified Data.ByteString as BS +import Data.FileEmbed (embedFile, + makeRelativeToProject) +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) + +import JSONSchema.Draft4.Failure (Invalid(..), + SchemaInvalid(..), + ValidatorFailure(..)) +import JSONSchema.Draft4.Schema (Schema) +import qualified JSONSchema.Draft4.Schema as SC +import qualified JSONSchema.Draft4.Spec as Spec +import JSONSchema.Fetch (ReferencedSchemas(..), + SchemaWithURI(..)) +import qualified JSONSchema.Fetch as FE + +data HTTPValidationFailure + = HVRequest FE.HTTPFailure + | HVSchema SchemaInvalid + | HVData Invalid + deriving Show + +-- | Fetch recursively referenced schemas over HTTP, check that both the +-- original and referenced schemas are valid, then validate then data. +fetchHTTPAndValidate + :: SchemaWithURI Schema + -> Value + -> IO (Either HTTPValidationFailure ()) +fetchHTTPAndValidate sw v = do + res <- referencesViaHTTP sw + pure (g =<< f =<< left HVRequest res) + where + f :: FE.URISchemaMap Schema + -> Either HTTPValidationFailure (Value -> [ValidatorFailure]) + f references = left HVSchema (checkSchema references sw) + + g :: (Value -> [ValidatorFailure]) -> Either HTTPValidationFailure () + g val = case NE.nonEmpty (val v) of + Nothing -> Right () + Just failures -> Left (HVData Invalid + { _invalidSchema = _swSchema sw + , _invalidInstance = v + , _invalidFailures = failures + }) + +data FilesystemValidationFailure + = FVRead FE.FilesystemFailure + | FVSchema SchemaInvalid + | FVData Invalid + deriving (Show, Eq) + +-- | Fetch recursively referenced schemas from the filesystem, check +-- that both the original and referenced schemas are valid, then validate +-- the data. +fetchFilesystemAndValidate + :: SchemaWithURI Schema + -> Value + -> IO (Either FilesystemValidationFailure ()) +fetchFilesystemAndValidate sw v = do + res <- referencesViaFilesystem sw + pure (g =<< f =<< left FVRead res) + where + f :: FE.URISchemaMap Schema + -> Either FilesystemValidationFailure (Value -> [ValidatorFailure]) + f references = left FVSchema (checkSchema references sw) + + g :: (Value -> [ValidatorFailure]) -> Either FilesystemValidationFailure () + g val = case NE.nonEmpty (val v) of + Nothing -> Right () + Just invalid -> Left (FVData Invalid + { _invalidSchema = _swSchema sw + , _invalidInstance = v + , _invalidFailures = invalid + }) + +-- | An instance of 'JSONSchema.Fetch.FetchInfo' specialized for +-- JSON Schema Draft 4. +draft4FetchInfo :: FE.FetchInfo Schema +draft4FetchInfo = FE.FetchInfo Spec.embedded SC._schemaId SC._schemaRef + +-- | Fetch the schemas recursively referenced by a starting schema over HTTP. +referencesViaHTTP + :: SchemaWithURI Schema + -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema)) +referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo + +-- | Fetch the schemas recursively referenced by a starting schema from +-- the filesystem. +referencesViaFilesystem + :: SchemaWithURI Schema + -> IO (Either FE.FilesystemFailure (FE.URISchemaMap Schema)) +referencesViaFilesystem = FE.referencesViaFilesystem' draft4FetchInfo + +-- | Checks if a schema and a set of referenced schemas are valid. +-- +-- Return a function to validate data. +checkSchema + :: FE.URISchemaMap Schema + -> SchemaWithURI Schema + -> Either SchemaInvalid (Value -> [ValidatorFailure]) +checkSchema sm sw = + case NE.nonEmpty failures of + Just fs -> Left (SchemaInvalid fs) + Nothing -> Right (Spec.specValidate + (ReferencedSchemas (_swSchema sw) + (FE._unURISchemaMap sm)) + sw) + where + failures :: [(Maybe Text, NonEmpty ValidatorFailure)] + failures = + let refFailures = first Just <$> referencesValidity sm + in case NE.nonEmpty (schemaValidity (_swSchema sw)) of + Nothing -> refFailures + Just errs -> (Nothing,errs) : refFailures + +metaSchema :: Schema +metaSchema = + fromMaybe (panic "Schema decode failed (this should never happen)") + . decodeStrict + $ metaSchemaBytes + +metaSchemaBytes :: BS.ByteString +metaSchemaBytes = + $(makeRelativeToProject "src/draft4.json" >>= embedFile) + +-- | Check that a schema itself is valid +-- (if so the returned list will be empty). +schemaValidity :: Schema -> [ValidatorFailure] +schemaValidity = + Spec.specValidate referenced (SchemaWithURI metaSchema Nothing) . toJSON + where + referenced :: ReferencedSchemas Schema + referenced = ReferencedSchemas + metaSchema + (HM.singleton "http://json-schema.org/draft-04/schema" + metaSchema) + +-- | Check that a set of referenced schemas are valid +-- (if so the returned list will be empty). +referencesValidity + :: FE.URISchemaMap Schema + -> [(Text, NonEmpty ValidatorFailure)] + -- ^ The first item of the tuple is the URI of a schema, the second + -- is that schema's validation errors. +referencesValidity = HM.foldlWithKey' f mempty . FE._unURISchemaMap + where + f :: [(Text, NonEmpty ValidatorFailure)] + -> Text + -> Schema + -> [(Text, NonEmpty ValidatorFailure)] + f acc k v = case NE.nonEmpty (schemaValidity v) of + Nothing -> acc + Just errs -> (k,errs) : acc diff --git a/src/JSONSchema/Draft4/Failure.hs b/src/JSONSchema/Draft4/Failure.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Draft4/Failure.hs @@ -0,0 +1,59 @@ + +module JSONSchema.Draft4.Failure where + +import Import + +import JSONSchema.Draft4.Schema (Schema) +import qualified JSONSchema.Validator.Draft4 as D4 + +-- | Used to report an entire instance being invalidated, as opposed +-- to the failure of a single validator. +data Invalid = Invalid + { _invalidSchema :: Schema + , _invalidInstance :: Value + , _invalidFailures :: NonEmpty ValidatorFailure + } deriving (Eq, Show) + +data ValidatorFailure + = FailureMultipleOf D4.MultipleOfInvalid + | FailureMaximum D4.MaximumInvalid + | FailureMinimum D4.MinimumInvalid + + | FailureMaxLength D4.MaxLengthInvalid + | FailureMinLength D4.MinLengthInvalid + | FailurePattern D4.PatternInvalid + + | FailureMaxItems D4.MaxItemsInvalid + | FailureMinItems D4.MinItemsInvalid + | FailureUniqueItems D4.UniqueItemsInvalid + | FailureItems (D4.ItemsInvalid ValidatorFailure) + | FailureAdditionalItems (D4.AdditionalItemsInvalid ValidatorFailure) + + | FailureMaxProperties D4.MaxPropertiesInvalid + | FailureMinProperties D4.MinPropertiesInvalid + | FailureRequired () + | FailureDependencies (D4.DependenciesInvalid ValidatorFailure) + | FailurePropertiesRelated (D4.PropertiesRelatedInvalid ValidatorFailure) + + | FailureRef (D4.RefInvalid ValidatorFailure) + | FailureEnum D4.EnumInvalid + | FailureType D4.TypeValidatorInvalid + | FailureAllOf (D4.AllOfInvalid ValidatorFailure) + | FailureAnyOf (D4.AnyOfInvalid ValidatorFailure) + | FailureOneOf (D4.OneOfInvalid ValidatorFailure) + | FailureNot D4.NotValidatorInvalid + deriving (Eq, Show) + +-- | A description of why a schema (or one of its reference) is itself +-- invalid. +-- +-- 'Nothing' indicates the starting schema. 'Just' indicates a referenced +-- schema. The contents of the 'Just' is the schema's URI. +-- +-- NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of +-- defining this, but then we lose the guarantee that there's at least +-- one key. +newtype SchemaInvalid + = SchemaInvalid { + _unSchemaInvalid :: NonEmpty (Maybe Text, NonEmpty ValidatorFailure) } + deriving (Eq, Show) diff --git a/src/JSONSchema/Draft4/Schema.hs b/src/JSONSchema/Draft4/Schema.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Draft4/Schema.hs @@ -0,0 +1,342 @@ + +module JSONSchema.Draft4.Schema where + +import Import hiding (mapMaybe) + +import qualified Data.HashMap.Strict as HM +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (fromJust, isJust) +import Data.Scientific +import qualified Data.Set as Set +import qualified Data.Text as T + +import qualified JSONSchema.Validator.Draft4 as D4 +import JSONSchema.Validator.Utils + +data Schema = Schema + { _schemaVersion :: Maybe Text + , _schemaId :: Maybe Text + , _schemaRef :: Maybe Text + , _schemaDefinitions :: Maybe (HashMap Text Schema) + -- ^ A standardized location for embedding schemas + -- to be referenced from elsewhere in the document. + , _schemaOther :: HashMap Text Value + -- ^ Since the JSON document this schema was built from could + -- contain schemas anywhere (not just in "definitions" or any + -- of the other official keys) we save any leftover key/value + -- pairs not covered by them here. + -- + -- TODO: This field is the source of most of the complication in this + -- module and needs to be removed. It should be doable, though it will + -- involve some modification to the fetching code. + + , _schemaMultipleOf :: Maybe Scientific + , _schemaMaximum :: Maybe Scientific + , _schemaExclusiveMaximum :: Maybe Bool + , _schemaMinimum :: Maybe Scientific + , _schemaExclusiveMinimum :: Maybe Bool + + , _schemaMaxLength :: Maybe Int + , _schemaMinLength :: Maybe Int + , _schemaPattern :: Maybe Text + + , _schemaMaxItems :: Maybe Int + , _schemaMinItems :: Maybe Int + , _schemaUniqueItems :: Maybe Bool + , _schemaItems :: Maybe (D4.Items Schema) + -- Note that '_schemaAdditionalItems' is left out of 'runValidate' + -- because its functionality is handled by '_schemaItems'. It always + -- validates data unless 'Items' is present. + , _schemaAdditionalItems :: Maybe (D4.AdditionalItems Schema) + + , _schemaMaxProperties :: Maybe Int + , _schemaMinProperties :: Maybe Int + , _schemaRequired :: Maybe (Set Text) + , _schemaDependencies :: Maybe (HashMap Text (D4.Dependency Schema)) + , _schemaProperties :: Maybe (HashMap Text Schema) + , _schemaPatternProperties :: Maybe (HashMap Text Schema) + , _schemaAdditionalProperties :: Maybe (D4.AdditionalProperties Schema) + + , _schemaEnum :: Maybe (NonEmpty Value) + , _schemaType :: Maybe D4.TypeValidator + , _schemaAllOf :: Maybe (NonEmpty Schema) + , _schemaAnyOf :: Maybe (NonEmpty Schema) + , _schemaOneOf :: Maybe (NonEmpty Schema) + , _schemaNot :: Maybe Schema + } deriving (Eq, Show) + +emptySchema :: Schema +emptySchema = Schema + { _schemaVersion = Nothing + , _schemaId = Nothing + , _schemaRef = Nothing + , _schemaDefinitions = Nothing + , _schemaOther = mempty + + , _schemaMultipleOf = Nothing + , _schemaMaximum = Nothing + , _schemaExclusiveMaximum = Nothing + , _schemaMinimum = Nothing + , _schemaExclusiveMinimum = Nothing + + , _schemaMaxLength = Nothing + , _schemaMinLength = Nothing + , _schemaPattern = Nothing + + , _schemaMaxItems = Nothing + , _schemaMinItems = Nothing + , _schemaUniqueItems = Nothing + , _schemaItems = Nothing + , _schemaAdditionalItems = Nothing + + , _schemaMaxProperties = Nothing + , _schemaMinProperties = Nothing + , _schemaRequired = Nothing + , _schemaDependencies = Nothing + , _schemaProperties = Nothing + , _schemaPatternProperties = Nothing + , _schemaAdditionalProperties = Nothing + + , _schemaEnum = Nothing + , _schemaType = Nothing + , _schemaAllOf = Nothing + , _schemaAnyOf = Nothing + , _schemaOneOf = Nothing + , _schemaNot = Nothing + } + +instance FromJSON Schema where + parseJSON = withObject "Schema" $ \o -> do + a <- o .:! "$schema" + b <- o .:! "id" + c <- o .:! "$ref" + d <- o .:! "definitions" + e <- parseJSON (Object (HM.difference o internalSchemaHashMap)) + + f <- o .:! "multipleOf" + g <- o .:! "maximum" + h <- o .:! "exclusiveMaximum" + i <- o .:! "minimum" + j <- o .:! "exclusiveMinimum" + + k <- o .:! "maxLength" + l <- o .:! "minLength" + m <- o .:! "pattern" + + n <- o .:! "maxItems" + o' <- o .:! "minItems" + p <- o .:! "uniqueItems" + q <- o .:! "items" + r <- o .:! "additionalItems" + + s <- o .:! "maxProperties" + t <- o .:! "minProperties" + u <- o .:! "required" + v <- o .:! "dependencies" + w <- o .:! "properties" + x <- o .:! "patternProperties" + y <- o .:! "additionalProperties" + + z <- o .:! "enum" + a2 <- o .:! "type" + b2 <- fmap _unNonEmpty' <$> o .:! "allOf" + c2 <- fmap _unNonEmpty' <$> o .:! "anyOf" + d2 <- fmap _unNonEmpty' <$> o .:! "oneOf" + e2 <- o .:! "not" + pure Schema + { _schemaVersion = a + , _schemaId = b + , _schemaRef = c + , _schemaDefinitions = d + , _schemaOther = e + + , _schemaMultipleOf = f + , _schemaMaximum = g + , _schemaExclusiveMaximum = h + , _schemaMinimum = i + , _schemaExclusiveMinimum = j + + , _schemaMaxLength = k + , _schemaMinLength = l + , _schemaPattern = m + + , _schemaMaxItems = n + , _schemaMinItems = o' + , _schemaUniqueItems = p + , _schemaItems = q + , _schemaAdditionalItems = r + + , _schemaMaxProperties = s + , _schemaMinProperties = t + , _schemaRequired = u + , _schemaDependencies = v + , _schemaProperties = w + , _schemaPatternProperties = x + , _schemaAdditionalProperties = y + + , _schemaEnum = z + , _schemaType = a2 + , _schemaAllOf = b2 + , _schemaAnyOf = c2 + , _schemaOneOf = d2 + , _schemaNot = e2 + } + +instance ToJSON Schema where + -- | The way we resolve JSON Pointers to embedded schemas is by + -- serializing the containing schema to a value and then resolving the + -- pointer against it. This means that FromJSON and ToJSON must be + -- isomorphic. + -- + -- This influences the design choices in the library. E.g. right now + -- there are two false values for "exclusiveMaximum" -- Nothing and + -- Just False. We could have condensed them down by using () instead + -- of Bool for "exclusiveMaximum". This would have made writing schemas + -- in haskell easier, but we could no longer round trip through/from + -- JSON without losing information. + toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap) + (toJSON <$> _schemaOther s) + where + -- 'mapMaybe' is provided by unordered-containers after + -- unordered-container-2.6.0.0, but until that is a little older + -- (and has time to get into Stackage etc.) we use our own + -- implementation. + mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 + mapMaybe f = fmap fromJust . HM.filter isJust . fmap f + +-- | Internal. Separate from ToJSON because it's also used +-- by FromJSON to determine what keys aren't official schema +-- keys and therefor should be included in _schemaOther. +internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value) +internalSchemaHashMap = HM.fromList + [ ("$schema" , f _schemaVersion) + , ("id" , f _schemaId) + , ("$ref" , f _schemaRef) + , ("definitions" , f _schemaDefinitions) + + , ("multipleOf" , f _schemaMultipleOf) + , ("maximum" , f _schemaMaximum) + , ("exclusiveMaximum" , f _schemaExclusiveMaximum) + , ("minimum" , f _schemaMinimum) + , ("exclusiveMinimum" , f _schemaExclusiveMinimum) + + , ("maxLength" , f _schemaMaxLength) + , ("minLength" , f _schemaMinLength) + , ("pattern" , f _schemaPattern) + + , ("maxItems" , f _schemaMaxItems) + , ("minItems" , f _schemaMinItems) + , ("uniqueItems" , f _schemaUniqueItems) + , ("items" , f _schemaItems) + , ("additionalItems" , f _schemaAdditionalItems) + + , ("maxProperties" , f _schemaMaxProperties) + , ("minProperties" , f _schemaMinProperties) + , ("required" , f _schemaRequired) + , ("dependencies" , f _schemaDependencies) + , ("properties" , f _schemaProperties) + , ("patternProperties" , f _schemaPatternProperties) + , ("additionalProperties", f _schemaAdditionalProperties) + + , ("enum" , f _schemaEnum) + , ("type" , f _schemaType) + , ("allOf" , f (fmap NonEmpty' . _schemaAllOf)) + , ("anyOf" , f (fmap NonEmpty' . _schemaAnyOf)) + , ("oneOf" , f (fmap NonEmpty' . _schemaOneOf)) + , ("not" , f _schemaNot) + ] + where + f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value + f = (fmap.fmap) toJSON + +instance Arbitrary Schema where + arbitrary = sized f + where + maybeGen :: Gen a -> Gen (Maybe a) + maybeGen a = oneof [pure Nothing, Just <$> a] + + maybeRecurse :: Int -> Gen a -> Gen (Maybe a) + maybeRecurse n a + | n < 1 = pure Nothing + | otherwise = maybeGen $ resize (n `div` 10) a + + f :: Int -> Gen Schema + f n = do + a <- maybeGen arbitraryText + b <- maybeGen arbitraryText + c <- maybeGen arbitraryText + -- NOTE: The next two fields are empty to generate cleaner + -- schemas, but note that this means we don't test the + -- invertability of these fields. + d <- pure Nothing -- _schemaDefinitions + e <- pure mempty -- _otherPairs + + f' <- maybeGen arbitraryPositiveScientific + g <- maybeGen arbitraryScientific + h <- arbitrary + i <- maybeGen arbitraryScientific + j <- arbitrary + + k <- maybeGen (getPositive <$> arbitrary) + l <- maybeGen (getPositive <$> arbitrary) + m <- maybeGen arbitraryText + + n' <- maybeGen (getPositive <$> arbitrary) + o <- maybeGen (getPositive <$> arbitrary) + p <- arbitrary + q <- maybeRecurse n arbitrary + r <- maybeRecurse n arbitrary + + s <- maybeGen (getPositive <$> arbitrary) + t <- maybeGen (getPositive <$> arbitrary) + u <- maybeGen (Set.map T.pack <$> arbitrary) + v <- maybeRecurse n arbitraryHashMap + w <- maybeRecurse n arbitraryHashMap + x <- maybeRecurse n arbitraryHashMap + y <- maybeRecurse n arbitrary + + z <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty' + <$> arbitrary) + a2 <- arbitrary + b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) + c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) + d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary) + e2 <- maybeRecurse n arbitrary + pure Schema + { _schemaVersion = a + , _schemaId = b + , _schemaRef = c + , _schemaDefinitions = d + , _schemaOther = e + + , _schemaMultipleOf = f' + , _schemaMaximum = g + , _schemaExclusiveMaximum = h + , _schemaMinimum = i + , _schemaExclusiveMinimum = j + + , _schemaMaxLength = k + , _schemaMinLength = l + , _schemaPattern = m + + , _schemaMaxItems = n' + , _schemaMinItems = o + , _schemaUniqueItems = p + , _schemaItems = q + , _schemaAdditionalItems = r + + , _schemaMaxProperties = s + , _schemaMinProperties = t + , _schemaRequired = u + , _schemaDependencies = v + , _schemaProperties = w + , _schemaPatternProperties = x + , _schemaAdditionalProperties = y + + , _schemaEnum = z + , _schemaType = a2 + , _schemaAllOf = b2 + , _schemaAnyOf = c2 + , _schemaOneOf = d2 + , _schemaNot = e2 + } diff --git a/src/JSONSchema/Draft4/Spec.hs b/src/JSONSchema/Draft4/Spec.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Draft4/Spec.hs @@ -0,0 +1,128 @@ + +module JSONSchema.Draft4.Spec where + +import Import + +import Data.Maybe (fromMaybe) +import Data.Profunctor (Profunctor(..)) + +import JSONSchema.Draft4.Failure +import JSONSchema.Draft4.Schema (Schema(..)) +import JSONSchema.Fetch (ReferencedSchemas(..), + SchemaWithURI(..)) +import qualified JSONSchema.Fetch as FE +import JSONSchema.Types (Spec(..)) +import qualified JSONSchema.Types as JT +import JSONSchema.Validator.Draft4 +import JSONSchema.Validator.Reference (updateResolutionScope) + +embedded :: Schema -> ([Schema], [Schema]) +embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s + +specValidate + :: ReferencedSchemas Schema + -> SchemaWithURI Schema + -> Value + -> [ValidatorFailure] +specValidate rs = + continueValidating rs (VisitedSchemas [(Nothing, Nothing)]) + +continueValidating + :: ReferencedSchemas Schema + -> VisitedSchemas + -> SchemaWithURI Schema + -> Value + -> [ValidatorFailure] +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 + -> VisitedSchemas + -> Maybe Text + -> Spec Schema ValidatorFailure +d4Spec referenced visited scope = Spec + [ dimap (fmap MultipleOf . _schemaMultipleOf) FailureMultipleOf multipleOfValidator + , dimap + (\s -> Maximum (fromMaybe False (_schemaExclusiveMaximum s)) <$> _schemaMaximum s) + FailureMaximum + maximumValidator + , dimap + (\s -> Minimum (fromMaybe False (_schemaExclusiveMinimum s)) <$> _schemaMinimum s) + FailureMinimum + minimumValidator + + , dimap (fmap MaxLength . _schemaMaxLength) FailureMaxLength maxLengthValidator + , dimap (fmap MinLength . _schemaMinLength) FailureMinLength minLengthValidator + , dimap (fmap PatternValidator . _schemaPattern) FailurePattern patternValidator + + , dimap (fmap MaxItems . _schemaMaxItems) FailureMaxItems maxItemsValidator + , dimap (fmap MinItems . _schemaMinItems) FailureMinItems minItemsValidator + , dimap (fmap UniqueItems . _schemaUniqueItems) FailureUniqueItems uniqueItemsValidator + , dimap + (\s -> ItemsRelated + { _irItems = _schemaItems s + , _irAdditional = _schemaAdditionalItems s + }) + (\err -> case err of + IRInvalidItems e -> FailureItems e + IRInvalidAdditional e -> FailureAdditionalItems e) + (itemsRelatedValidator descend) + , lmap (fmap Definitions . _schemaDefinitions) definitionsEmbedded + + , dimap + (fmap MaxProperties . _schemaMaxProperties) + FailureMaxProperties + maxPropertiesValidator + , dimap + (fmap MinProperties . _schemaMinProperties) + FailureMinProperties + minPropertiesValidator + , dimap (fmap Required . _schemaRequired) FailureRequired requiredValidator + , dimap + (fmap DependenciesValidator . _schemaDependencies) + FailureDependencies + (dependenciesValidator descend) + , dimap + (\s -> PropertiesRelated + { _propProperties = _schemaProperties s + , _propPattern = _schemaPatternProperties s + , _propAdditional = _schemaAdditionalProperties s + }) + FailurePropertiesRelated + (propertiesRelatedValidator descend) + + , dimap + (\s -> Ref <$> _schemaRef s) + FailureRef + (refValidator visited scope (FE.getReference referenced) getRef) + , dimap (fmap EnumValidator . _schemaEnum) FailureEnum enumValidator + , dimap (fmap TypeContext . _schemaType) FailureType typeValidator + , dimap (fmap AllOf . _schemaAllOf) FailureAllOf (allOfValidator lateral) + , dimap (fmap AnyOf . _schemaAnyOf) FailureAnyOf (anyOfValidator lateral) + , dimap (fmap OneOf . _schemaOneOf) FailureOneOf (oneOfValidator lateral) + , dimap (fmap NotValidator . _schemaNot) FailureNot (notValidator lateral) + ] + where + getRef + :: VisitedSchemas + -> Maybe Text + -> Schema + -> Value + -> [ValidatorFailure] + getRef newVisited newScope schema = + continueValidating referenced newVisited (SchemaWithURI schema newScope) + + descend :: Schema -> Value -> [ValidatorFailure] + descend schema = + continueValidating referenced mempty (SchemaWithURI schema scope) + + lateral :: Schema -> Value -> [ValidatorFailure] + lateral schema = + continueValidating referenced visited (SchemaWithURI schema scope) diff --git a/src/JSONSchema/Fetch.hs b/src/JSONSchema/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Fetch.hs @@ -0,0 +1,194 @@ + +module JSONSchema.Fetch where + +import Import + +import Control.Arrow (left) +import Control.Exception (IOException, catch) +import Control.Monad (foldM) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Network.HTTP.Client as NC + +import JSONSchema.Validator.Reference (resolveReference, + updateResolutionScope) + +-------------------------------------------------- +-- * Types +-------------------------------------------------- + +-- | This is all the fetching functions need to know about a particular +-- JSON Schema draft, e.g. JSON Schema Draft 4. +data FetchInfo schema = FetchInfo + { _fiEmbedded :: schema -> ([schema], [schema]) + , _fiId :: schema -> Maybe Text + , _fiRef :: schema -> Maybe Text + } + +data ReferencedSchemas schema = ReferencedSchemas + { _rsStarting :: !schema + -- ^ Used to resolve relative references when we don't know what the scope + -- of the current schema is. This only happens with starting schemas + -- because if we're using a remote schema we had to know its URI in order + -- to fetch it. + -- + -- Tracking the starting schema (instead of just resolving the reference to + -- the current schema being used for validation) is necessary for cases + -- where schemas are embedded inside one another. For instance in this + -- case not distinguishing the starting and "foo" schemas sends the code + -- into an infinite loop: + -- + -- { + -- "additionalProperties": false, + -- "properties": { + -- "foo": { + -- "$ref": "#" + -- } + -- } + -- } + , _rsSchemaMap :: !(HashMap Text schema) + -- ^ Map of URIs to schemas. + } deriving (Eq, Show) + +-- | Keys are URIs (without URI fragments). +newtype URISchemaMap schema + = URISchemaMap { _unURISchemaMap :: HashMap Text schema } + deriving (Eq, Show) + +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) = HM.lookup t (_rsSchemaMap referenced) + +-------------------------------------------------- +-- * Fetch via HTTP +-------------------------------------------------- + +data HTTPFailure + = HTTPParseFailure Text + | HTTPRequestFailure NC.HttpException + deriving Show + +-- | Take a schema. Retrieve every document either it or its subschemas +-- include via the "$ref" keyword. +referencesViaHTTP' + :: forall schema. FromJSON schema + => FetchInfo schema + -> SchemaWithURI schema + -> IO (Either HTTPFailure (URISchemaMap schema)) +referencesViaHTTP' info sw = do + manager <- NC.newManager NC.defaultManagerSettings + let f = referencesMethodAgnostic (getURL manager) info sw + catch (left HTTPParseFailure <$> f) handler + where + getURL :: NC.Manager -> Text -> IO BS.ByteString + getURL man url = do + request <- NC.parseUrlThrow (T.unpack url) + LBS.toStrict . NC.responseBody <$> NC.httpLbs request man + + handler + :: NC.HttpException + -> IO (Either HTTPFailure (URISchemaMap schema)) + handler = pure . Left . HTTPRequestFailure + +-------------------------------------------------- +-- * Fetch via Filesystem +-------------------------------------------------- + +data FilesystemFailure + = FSParseFailure Text + | FSReadFailure IOException + deriving (Show, Eq) + +referencesViaFilesystem' + :: forall schema. FromJSON schema + => FetchInfo schema + -> SchemaWithURI schema + -> IO (Either FilesystemFailure (URISchemaMap schema)) +referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler + where + f :: IO (Either Text (URISchemaMap schema)) + f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw + + handler + :: IOException + -> IO (Either FilesystemFailure (URISchemaMap schema)) + handler = pure . Left . FSReadFailure + +-------------------------------------------------- +-- * Method Agnostic Fetching Tools +-------------------------------------------------- + +-- | A version of 'fetchReferencedSchema's where the function to fetch +-- schemas is provided by the user. This allows restrictions to be added, +-- e.g. rejecting non-local URIs. +referencesMethodAgnostic + :: forall schema. FromJSON schema + => (Text -> IO BS.ByteString) + -> FetchInfo schema + -> SchemaWithURI schema + -> IO (Either Text (URISchemaMap schema)) +referencesMethodAgnostic fetchRef info = + getRecursiveReferences fetchRef info (URISchemaMap mempty) + +getRecursiveReferences + :: forall schema. FromJSON schema + => (Text -> IO BS.ByteString) + -> FetchInfo schema + -> URISchemaMap schema + -> SchemaWithURI schema + -> IO (Either Text (URISchemaMap schema)) +getRecursiveReferences fetchRef info referenced sw = + foldM f (Right referenced) (includeSubschemas info sw) + where + f :: Either Text (URISchemaMap schema) + -> SchemaWithURI schema + -> IO (Either Text (URISchemaMap schema)) + f (Left e) _ = pure (Left e) + f (Right (URISchemaMap usm)) (SchemaWithURI schema mUri) = + case newRef of + Nothing -> pure (Right (URISchemaMap usm)) + Just uri -> do + bts <- fetchRef uri + case eitherDecodeStrict bts of + Left e -> pure . Left . T.pack $ e + Right schm -> getRecursiveReferences + fetchRef + info + (URISchemaMap (HM.insert uri schm usm)) + (SchemaWithURI schm (Just uri)) + where + newRef :: Maybe Text + newRef + | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema + = case HM.lookup uri usm of + Nothing -> Just uri + Just _ -> Nothing + | otherwise = Nothing + +-- | Return the schema passed in as an argument, as well as every +-- subschema contained within it. +includeSubschemas + :: forall schema. + FetchInfo schema + -> SchemaWithURI schema + -> [SchemaWithURI schema] +includeSubschemas info (SchemaWithURI schema mUri) = + SchemaWithURI schema mUri + : (includeSubschemas info =<< subSchemas) + where + subSchemas :: [SchemaWithURI schema] + subSchemas = + (\a -> SchemaWithURI a (updateResolutionScope mUri (_fiId info schema))) + <$> uncurry (<>) (_fiEmbedded info schema) diff --git a/src/JSONSchema/Types.hs b/src/JSONSchema/Types.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Types.hs @@ -0,0 +1,36 @@ + +module JSONSchema.Types where + +import Import + +import JSONSchema.Validator.Types (Validator(..)) + +newtype Spec schema err + = Spec { _unSpec :: [Validator schema schema err] } + +-- | Return a schema's immediate subschemas. +-- +-- The first list is subschemas validating the same level of the document, +-- the second list is subschemas validating lower levels (see +-- 'JSONSchema.Validator.Types.Fail' for a full explanation). +embedded :: Spec schema a -> schema -> ([schema], [schema]) +embedded spec schema = + let embeds = (\val -> _embedded val schema) <$> _unSpec spec + in foldl' (\(a,b) (x,y) -> (x <> a, y <> b)) (mempty, mempty) embeds + +validate + :: Spec schema err + -> schema + -> Value + -> [err] +validate spec schema v = + (\val -> _validate val schema v) =<< _unSpec spec + +-- | A basic schema type that doesn't impose much structure. +-- +-- 'JSONSchema.Draft4' doesn't use this, but instead uses the record based +-- one defined in 'JSONSchema.Draft4.Schema' to make it easier to write +-- draft 4 schemas in Haskell. +newtype Schema + = Schema { _unSchema :: HashMap Text Value } + deriving (Eq, Show, FromJSON, ToJSON) diff --git a/src/JSONSchema/Validator/Draft4.hs b/src/JSONSchema/Validator/Draft4.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4.hs @@ -0,0 +1,242 @@ +-- | Turn the validation functions into actual 'Validator's. + +module JSONSchema.Validator.Draft4 + ( module JSONSchema.Validator.Draft4 + , module Export + ) where + +import Import + +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Maybe (catMaybes, maybe, maybeToList) +import Data.Text (Text) + +import JSONSchema.Validator.Draft4.Any as Export +import JSONSchema.Validator.Draft4.Array as Export +import JSONSchema.Validator.Draft4.Number as Export +import JSONSchema.Validator.Draft4.Object as Export +import JSONSchema.Validator.Draft4.String as Export +import JSONSchema.Validator.Types (Validator(..)) +import JSONSchema.Validator.Utils (fromJSONEither) + +-- | For internal use. +-- +-- Take a validation function, a possibly existing validator, and some data. +-- If the validator is exists and can validate the type of data we have, +-- attempt to do so and return any failures. +run :: FromJSON b => (a -> b -> Maybe c) -> Maybe a -> Value -> [c] +run _ Nothing _ = mempty +run f (Just a) b = + case fromJSONEither b of + Left _ -> mempty + Right c -> maybeToList (f a c) + +-- | For internal use. +noEmbedded :: a -> ([b], [b]) +noEmbedded = const (mempty, mempty) + +-------------------------------------------------- +-- * Numbers +-------------------------------------------------- + +multipleOfValidator :: Validator a (Maybe MultipleOf) MultipleOfInvalid +multipleOfValidator = Validator noEmbedded (run multipleOfVal) + +maximumValidator :: Validator a (Maybe Maximum) MaximumInvalid +maximumValidator = Validator noEmbedded (run maximumVal) + +minimumValidator :: Validator a (Maybe Minimum) MinimumInvalid +minimumValidator = Validator noEmbedded (run minimumVal) + +-------------------------------------------------- +-- * Strings +-------------------------------------------------- + +maxLengthValidator :: Validator a (Maybe MaxLength) MaxLengthInvalid +maxLengthValidator = Validator noEmbedded (run maxLengthVal) + +minLengthValidator :: Validator a (Maybe MinLength) MinLengthInvalid +minLengthValidator = Validator noEmbedded (run minLengthVal) + +patternValidator :: Validator a (Maybe PatternValidator) PatternInvalid +patternValidator = Validator noEmbedded (run patternVal) + +-------------------------------------------------- +-- * Arrays +-------------------------------------------------- + +maxItemsValidator :: Validator a (Maybe MaxItems) MaxItemsInvalid +maxItemsValidator = Validator noEmbedded (run maxItemsVal) + +minItemsValidator :: Validator a (Maybe MinItems) MinItemsInvalid +minItemsValidator = Validator noEmbedded (run minItemsVal) + +uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid +uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal) + +itemsRelatedValidator + :: (schema -> Value -> [err]) + -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err) +itemsRelatedValidator f = + Validator + (\a -> ( mempty + , case _irItems a of + Just (ItemsObject b) -> pure b + Just (ItemsArray cs) -> cs + Nothing -> mempty + <> case _irAdditional a of + Just (AdditionalObject b) -> pure b + _ -> mempty + )) + (\a b -> case fromJSONEither b of + Left _ -> mempty + Right c -> itemsRelatedVal f a c) + +-------------------------------------------------- +-- * Objects +-------------------------------------------------- + +maxPropertiesValidator + :: Validator + a + (Maybe MaxProperties) + MaxPropertiesInvalid +maxPropertiesValidator = Validator noEmbedded (run maxPropertiesVal) + +minPropertiesValidator + :: Validator + a + (Maybe MinProperties) + MinPropertiesInvalid +minPropertiesValidator = Validator noEmbedded (run minPropertiesVal) + +requiredValidator :: Validator a (Maybe Required) () +requiredValidator = Validator noEmbedded (run requiredVal) + +dependenciesValidator + :: (schema -> Value -> [err]) + -> Validator + schema + (Maybe (DependenciesValidator schema)) + (DependenciesInvalid err) +dependenciesValidator f = + Validator + (maybe mempty ( (\a -> (mempty, a)) + . catMaybes . fmap checkDependency + . HM.elems . _unDependenciesValidator + )) + (run (dependenciesVal f)) + where + checkDependency :: Dependency schema -> Maybe schema + checkDependency (PropertyDependency _) = Nothing + checkDependency (SchemaDependency s) = Just s + +propertiesRelatedValidator + :: (schema -> Value -> [err]) + -> Validator + schema + (PropertiesRelated schema) + (PropertiesRelatedInvalid err) +propertiesRelatedValidator f = + Validator + (\a -> ( mempty + , HM.elems (fromMaybe mempty (_propProperties a)) + <> HM.elems (fromMaybe mempty (_propPattern a)) + <> case _propAdditional a of + Just (AdditionalPropertiesObject b) -> [b] + _ -> mempty + )) + (\a b -> case fromJSONEither b of + Left _ -> mempty + Right c -> maybeToList (propertiesRelatedVal f a c)) + +newtype Definitions schema + = Definitions { _unDefinitions :: HashMap Text schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (Definitions schema) where + parseJSON = withObject "Definitions" $ \o -> + Definitions <$> o .: "definitions" + +-- TODO: Add tests to the language agnostic test suite to +-- make sure these schemas are embedded correctly +-- (and do so for @"additionalItems"@ as well). +definitionsEmbedded + :: Validator + schema + (Maybe (Definitions schema)) + err +definitionsEmbedded = + Validator + (\a -> case a of + Just (Definitions b) -> (mempty, HM.elems b) + Nothing -> (mempty, mempty)) + (const (const mempty)) + +-------------------------------------------------- +-- * Any +-------------------------------------------------- + +refValidator + :: (FromJSON schema, ToJSON schema) + => VisitedSchemas + -> Maybe Text + -> (Maybe Text -> Maybe schema) + -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err]) + -> Validator a (Maybe Ref) (RefInvalid err) +refValidator visited scope getRef f = + Validator + noEmbedded + (run (refVal visited scope getRef f)) + +enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid +enumValidator = Validator noEmbedded (run enumVal) + +typeValidator :: Validator a (Maybe TypeContext) TypeValidatorInvalid +typeValidator = Validator noEmbedded (run typeVal) + +allOfValidator + :: (schema -> Value -> [err]) + -> Validator schema (Maybe (AllOf schema)) (AllOfInvalid err) +allOfValidator f = + Validator + (\a -> case a of + Just (AllOf b) -> (NE.toList b, mempty) + Nothing -> (mempty, mempty)) + (run (allOfVal f)) + +anyOfValidator + :: (schema -> Value -> [err]) + -> Validator schema (Maybe (AnyOf schema)) (AnyOfInvalid err) +anyOfValidator f = + Validator + (\a -> case a of + Just (AnyOf b) -> (NE.toList b, mempty) + Nothing -> (mempty, mempty)) + (run (anyOfVal f)) + +oneOfValidator + :: ToJSON schema + => (schema -> Value -> [err]) + -> Validator schema (Maybe (OneOf schema)) (OneOfInvalid err) +oneOfValidator f = + Validator + (\a -> case a of + Just (OneOf b) -> (NE.toList b, mempty) + Nothing -> (mempty, mempty)) + (run (oneOfVal f)) + +notValidator + :: ToJSON schema + => (schema -> Value -> [err]) + -> Validator + schema + (Maybe (NotValidator schema)) + NotValidatorInvalid +notValidator f = + Validator + (\a -> case a of + Just (NotValidator b) -> (pure b, mempty) + Nothing -> (mempty, mempty)) + (run (notVal f)) diff --git a/src/JSONSchema/Validator/Draft4/Any.hs b/src/JSONSchema/Validator/Draft4/Any.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Any.hs @@ -0,0 +1,351 @@ + +module JSONSchema.Validator.Draft4.Any where + +import Import + +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NE +import qualified Data.Scientific as SCI +import Data.Semigroup (Semigroup) -- for older GHCs +import Data.Set (Set) +import qualified Data.Set as S +import qualified JSONPointer as JP + +import qualified JSONSchema.Validator.Utils as UT +import JSONSchema.Validator.Reference (URIBaseAndFragment, + resolveFragment, + resolveReference) + +-------------------------------------------------- +-- * $ref +-------------------------------------------------- + +newtype Ref + = Ref { _unRef :: Text } + deriving (Eq, Show) + +instance FromJSON Ref where + parseJSON = withObject "Ref" $ \o -> + Ref <$> o .: "$ref" + +data RefInvalid err + = RefResolution Text + -- ^ Indicates a reference that failed to resolve. + -- + -- NOTE: The language agnostic test suite doesn't specify if this should + -- cause a validation error or should allow data to pass. We choose to + -- return a validation error. + -- + -- Also note that ideally we would enforce in the type system that any + -- failing references be dealt with before valididation. Then this could + -- be removed entirely. + | RefPointerResolution Text + | RefLoop Text VisitedSchemas URIBaseAndFragment + | RefInvalid Text Value (NonEmpty err) + -- ^ 'Text' is the URI and 'Value' is the linked schema. + deriving (Eq, Show) + +newtype VisitedSchemas + = VisitedSchemas { _unVisited :: [URIBaseAndFragment] } + deriving (Eq, Show, Semigroup, Monoid) + +refVal + :: forall err schema. (FromJSON schema, ToJSON schema) + => VisitedSchemas + -> Maybe Text + -> (Maybe Text -> Maybe schema) + -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err]) + -> Ref + -> Value + -> Maybe (RefInvalid err) +refVal visited scope getRef f (Ref reference) x + | (mURI, mFragment) `elem` _unVisited visited = + Just (RefLoop reference visited (mURI, mFragment)) + | otherwise = + case getRef mURI of + Nothing -> Just (RefResolution reference) + Just schema -> + case resolveFragment mFragment schema of + Nothing -> Just (RefPointerResolution reference) + Just s -> + let newVisited = (VisitedSchemas [(mURI, mFragment)] + <> visited) + errs = f newVisited mURI s x + in RefInvalid reference (toJSON schema) + <$> NE.nonEmpty errs + where + (mURI, mFragment) = resolveReference scope reference + +-------------------------------------------------- +-- * enum +-------------------------------------------------- + +-- | From the spec: +-- +-- +-- > The value of this keyword MUST be an array. +-- > This array MUST have at least one element. +-- > Elements in the array MUST be unique. +-- +-- NOTE: We don't enforce the uniqueness constraint in the haskell code, +-- but we do in the 'FromJSON' instance. +newtype EnumValidator + = EnumValidator { _unEnumValidator :: NonEmpty Value } + -- Given a choice, we'd prefer to enforce uniqueness through the type + -- system over having at least one element. To use a 'Set' though we'd + -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values) + -- and we'd rather not make users mess with 'OrdValue'. + deriving (Eq, Show) + +instance FromJSON EnumValidator where + parseJSON = withObject "EnumValidator" $ \o -> + EnumValidator <$> o .: "enum" + +instance Arbitrary EnumValidator where + arbitrary = do + xs <- (fmap.fmap) UT._unArbitraryValue arbitrary + case NE.nonEmpty (toUnique xs) of + Nothing -> EnumValidator . pure . UT._unArbitraryValue <$> arbitrary + Just ne -> pure (EnumValidator ne) + where + toUnique :: [Value] -> [Value] + toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue + +data EnumInvalid + = EnumInvalid EnumValidator Value + deriving (Eq, Show) + +enumVal :: EnumValidator -> Value -> Maybe EnumInvalid +enumVal a@(EnumValidator vs) x + | not (UT.allUniqueValues' vs) = Nothing + | x `elem` vs = Nothing + | otherwise = Just $ EnumInvalid a x + +-------------------------------------------------- +-- * type +-------------------------------------------------- + +-- | This is separate from 'TypeValidator' so that 'TypeValidator' can +-- be used to write 'JSONSchema.Draft4.Schema.Schema' without +-- messing up the 'FromJSON' instance of that data type. +newtype TypeContext + = TypeContext { _unTypeContext :: TypeValidator } + deriving (Eq, Show) + +instance FromJSON TypeContext where + parseJSON = withObject "TypeContext" $ \o -> + TypeContext <$> o .: "type" + +data TypeValidator + = TypeValidatorString Text + | TypeValidatorArray (Set Text) + deriving (Eq, Show) + +instance FromJSON TypeValidator where + parseJSON v = fmap TypeValidatorString (parseJSON v) + <|> fmap TypeValidatorArray (parseJSON v) + +instance ToJSON TypeValidator where + toJSON (TypeValidatorString t) = toJSON t + toJSON (TypeValidatorArray ts) = toJSON ts + +instance Arbitrary TypeValidator where + arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText + , TypeValidatorArray <$> UT.arbitrarySetOfText + ] + +data TypeValidatorInvalid + = TypeValidatorInvalid TypeValidator Value + deriving (Eq, Show) + +typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid +typeVal (TypeContext tv) x + | S.null matches = Just (TypeValidatorInvalid tv x) + | otherwise = Nothing + where + -- There can be more than one match because a 'Value' can be both a + -- @"number"@ and an @"integer"@. + matches :: Set Text + matches = S.intersection okTypes (setFromTypeValidator tv) + + okTypes :: Set Text + okTypes = + case x of + Null -> S.singleton "null" + (Array _) -> S.singleton "array" + (Bool _) -> S.singleton "boolean" + (Object _) -> S.singleton "object" + (String _) -> S.singleton "string" + (Number y) -> + if SCI.isInteger y + then S.fromList ["number", "integer"] + else S.singleton "number" + +-- | Internal. +setFromTypeValidator :: TypeValidator -> Set Text +setFromTypeValidator (TypeValidatorString t) = S.singleton t +setFromTypeValidator (TypeValidatorArray ts) = ts + +-------------------------------------------------- +-- * allOf +-------------------------------------------------- + +newtype AllOf schema + = AllOf { _unAllOf :: NonEmpty schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (AllOf schema) where + parseJSON = withObject "AllOf" $ \o -> + AllOf <$> o .: "allOf" + +newtype AllOfInvalid err + = AllOfInvalid (NonEmpty (JP.Index, NonEmpty err)) + deriving (Eq, Show) + +allOfVal + :: forall err schema. + (schema -> Value -> [err]) + -> AllOf schema + -> Value + -> Maybe (AllOfInvalid err) +allOfVal f (AllOf subSchemas) x = AllOfInvalid <$> NE.nonEmpty failures + where + perhapsFailures :: [(JP.Index, [err])] + perhapsFailures = zip (JP.Index <$> [0..]) + (flip f x <$> NE.toList subSchemas) + + failures :: [(JP.Index, NonEmpty err)] + failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures + +-------------------------------------------------- +-- * anyOf +-------------------------------------------------- + +newtype AnyOf schema + = AnyOf { _unAnyOf :: NonEmpty schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (AnyOf schema) where + parseJSON = withObject "AnyOf" $ \o -> + AnyOf <$> o .: "anyOf" + +newtype AnyOfInvalid err + = AnyOfInvalid (NonEmpty (JP.Index, NonEmpty err)) + deriving (Eq, Show) + +anyOfVal + :: forall err schema. + (schema -> Value -> [err]) + -> AnyOf schema + -> Value + -> Maybe (AnyOfInvalid err) +anyOfVal f (AnyOf subSchemas) x + -- Replace with @null@ once we drop GHC 7.8: + | any (((==) 0 . length) . snd) perhapsFailures = Nothing + | otherwise = AnyOfInvalid <$> NE.nonEmpty failures + where + perhapsFailures :: [(JP.Index, [err])] + perhapsFailures = zip (JP.Index <$> [0..]) + (flip f x <$> NE.toList subSchemas) + + failures :: [(JP.Index, NonEmpty err)] + failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures + +-------------------------------------------------- +-- * oneOf +-------------------------------------------------- + +newtype OneOf schema + = OneOf { _unOneOf :: NonEmpty schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (OneOf schema) where + parseJSON = withObject "OneOf" $ \o -> + OneOf <$> o .: "oneOf" + +data OneOfInvalid err + = TooManySuccesses (NonEmpty (JP.Index, Value)) Value + -- ^ The NonEmpty lists contains tuples whose contents + -- are the index of a schema that validated the data + -- and the contents of that schema. + | NoSuccesses (NonEmpty (JP.Index, NonEmpty err)) Value + -- ^ The NonEmpty lists contains tuples whose contents + -- are the index of a schema that failed to validate the data + -- and the failures it produced. + deriving (Eq, Show) + +oneOfVal + :: forall err schema. ToJSON schema + => (schema -> Value -> [err]) + -> OneOf schema + -> Value + -> Maybe (OneOfInvalid err) +oneOfVal f (OneOf (firstSubSchema :| otherSubSchemas)) x = + -- Producing the NonEmpty lists needed by the error constructors + -- is a little tricky. If we had a partition function like this + -- it might help: + -- @ + -- (a -> Either b c) -> NonEmpty a -> Either (NonEmpty b, [c]) + -- ([b], NonEmpty c) + -- @ + case (firstSuccess, otherSuccesses) of + (Right _, Nothing) -> Nothing + (Right a, Just successes) -> Just (TooManySuccesses + (a NE.<| successes) x) + (Left e, Nothing) -> Just (NoSuccesses (e :| otherFailures) x) + (Left _, Just (_ :| [])) -> Nothing + (Left _, Just successes) -> Just (TooManySuccesses successes x) + where + firstSuccess :: Either (JP.Index, NonEmpty err) (JP.Index, Value) + firstSuccess = + case NE.nonEmpty (f firstSubSchema x) of + Nothing -> Right (JP.Index 0, toJSON firstSubSchema) + Just errs -> Left (JP.Index 0, errs) + + otherPerhapsFailures :: [(JP.Index, Value, [err])] + otherPerhapsFailures = + zipWith + (\index schema -> (index, toJSON schema, f schema x)) + (JP.Index <$> [0..]) + otherSubSchemas + + otherSuccesses :: Maybe (NonEmpty (JP.Index, Value)) + otherSuccesses = NE.nonEmpty + $ mapMaybe (\(index,val,errs) -> + case errs of + [] -> Just (index,val) + _ -> Nothing + ) otherPerhapsFailures + + otherFailures :: [(JP.Index, NonEmpty err)] + otherFailures = mapMaybe (traverse NE.nonEmpty . mid) otherPerhapsFailures + + mid :: (a,b,c) -> (a,c) + mid (a,_,c) = (a,c) + +-------------------------------------------------- +-- * not +-------------------------------------------------- + +newtype NotValidator schema + = NotValidator { _unNotValidator :: schema } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (NotValidator schema) where + parseJSON = withObject "NotValidator" $ \o -> + NotValidator <$> o .: "not" + +data NotValidatorInvalid + = NotValidatorInvalid Value Value + deriving (Eq, Show) + +notVal + :: ToJSON schema => + (schema -> Value -> [err]) + -> NotValidator schema + -> Value + -> Maybe NotValidatorInvalid +notVal f (NotValidator schema) x = + case f schema x of + [] -> Just (NotValidatorInvalid (toJSON schema) x) + _ -> Nothing diff --git a/src/JSONSchema/Validator/Draft4/Array.hs b/src/JSONSchema/Validator/Draft4/Array.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Array.hs @@ -0,0 +1,224 @@ + +module JSONSchema.Validator.Draft4.Array where + +import Import + +import qualified Data.List.NonEmpty as NE +import qualified Data.Vector as V +import qualified JSONPointer as JP + +import JSONSchema.Validator.Utils (allUniqueValues) + +-------------------------------------------------- +-- * maxItems +-------------------------------------------------- + +newtype MaxItems + = MaxItems { _unMaxItems :: Int } + deriving (Eq, Show) + +instance FromJSON MaxItems where + parseJSON = withObject "MaxItems" $ \o -> + MaxItems <$> o .: "maxItems" + +data MaxItemsInvalid + = MaxItemsInvalid MaxItems (Vector Value) + deriving (Eq, Show) + +-- | The spec requires @"maxItems"@ to be non-negative. +maxItemsVal :: MaxItems -> Vector Value -> Maybe MaxItemsInvalid +maxItemsVal a@(MaxItems n) xs + | n < 0 = Nothing + | V.length xs > n = Just (MaxItemsInvalid a xs) + | otherwise = Nothing + +-------------------------------------------------- +-- * minItems +-------------------------------------------------- + +newtype MinItems + = MinItems { _unMinItems :: Int } + deriving (Eq, Show) + +instance FromJSON MinItems where + parseJSON = withObject "MinItems" $ \o -> + MinItems <$> o .: "minItems" + +data MinItemsInvalid + = MinItemsInvalid MinItems (Vector Value) + deriving (Eq, Show) + +-- | The spec requires @"minItems"@ to be non-negative. +minItemsVal :: MinItems -> Vector Value -> Maybe MinItemsInvalid +minItemsVal a@(MinItems n) xs + | n < 0 = Nothing + | V.length xs < n = Just (MinItemsInvalid a xs) + | otherwise = Nothing + +-------------------------------------------------- +-- * uniqueItems +-------------------------------------------------- + +newtype UniqueItems + = UniqueItems { _unUniqueItems :: Bool } + deriving (Eq, Show) + +instance FromJSON UniqueItems where + parseJSON = withObject "UniqueItems" $ \o -> + UniqueItems <$> o .: "uniqueItems" + +data UniqueItemsInvalid + = UniqueItemsInvalid (Vector Value) + deriving (Eq, Show) + +uniqueItemsVal :: UniqueItems -> Vector Value -> Maybe UniqueItemsInvalid +uniqueItemsVal (UniqueItems True) xs + | allUniqueValues xs = Nothing + | otherwise = Just (UniqueItemsInvalid xs) +uniqueItemsVal (UniqueItems False) _ = Nothing + +-------------------------------------------------- +-- * items +-------------------------------------------------- + +data ItemsRelated schema = ItemsRelated + { _irItems :: Maybe (Items schema) + , _irAdditional :: Maybe (AdditionalItems schema) + } deriving (Eq, Show) + +instance FromJSON schema => FromJSON (ItemsRelated schema) where + parseJSON = withObject "ItemsRelated" $ \o -> ItemsRelated + <$> o .:! "items" + <*> o .:! "additionalItems" + +emptyItems :: ItemsRelated schema +emptyItems = ItemsRelated + { _irItems = Nothing + , _irAdditional = Nothing + } + +data Items schema + = ItemsObject schema + | ItemsArray [schema] + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (Items schema) where + parseJSON v = fmap ItemsObject (parseJSON v) + <|> fmap ItemsArray (parseJSON v) + +instance ToJSON schema => ToJSON (Items schema) where + toJSON (ItemsObject hm) = toJSON hm + toJSON (ItemsArray schemas) = toJSON schemas + +instance Arbitrary schema => Arbitrary (Items schema) where + arbitrary = oneof [ ItemsObject <$> arbitrary + , ItemsArray <$> arbitrary + ] + +data ItemsRelatedInvalid err + = IRInvalidItems (ItemsInvalid err) + | IRInvalidAdditional (AdditionalItemsInvalid err) + deriving (Eq, Show) + +data ItemsInvalid err + = ItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err)) + | ItemsArrayInvalid (NonEmpty (JP.Index, NonEmpty err)) + deriving (Eq, Show) + +-- | @"additionalItems"@ only matters if @"items"@ exists +-- and is a JSON Array. +itemsRelatedVal + :: forall err schema. + (schema -> Value -> [err]) + -> ItemsRelated schema + -> Vector Value + -> [ItemsRelatedInvalid err] -- NOTE: 'Data.These' would help here. +itemsRelatedVal f a xs = + let (itemsFailure, remaining) = case _irItems a of + Nothing -> (Nothing, mempty) + Just b -> itemsVal f b xs + additionalFailure = (\b -> additionalItemsVal f b remaining) + =<< _irAdditional a + in catMaybes [ IRInvalidItems <$> itemsFailure + , IRInvalidAdditional <$> additionalFailure + ] + +-- | Internal. +-- +-- This is because 'itemsRelated' handles @"items"@ validation. +itemsVal + :: forall err schema. + (schema -> Value -> [err]) + -> Items schema + -> Vector Value + -> (Maybe (ItemsInvalid err), [(JP.Index, Value)]) + -- ^ The second item in the tuple is the elements of the original + -- JSON Array still remaining to be checked by @"additionalItems"@. +itemsVal f a xs = + case a of + ItemsObject subSchema -> + case NE.nonEmpty (mapMaybe (validateElem subSchema) indexed) of + Nothing -> (Nothing, mempty) + Just errs -> (Just (ItemsObjectInvalid errs), mempty) + ItemsArray subSchemas -> + let remaining = drop (length subSchemas) indexed + res = catMaybes (zipWith validateElem subSchemas indexed) + in case NE.nonEmpty res of + Nothing -> (Nothing, remaining) + Just errs -> (Just (ItemsArrayInvalid errs), remaining) + where + indexed :: [(JP.Index, Value)] + indexed = zip (JP.Index <$> [0..]) (V.toList xs) + + validateElem + :: schema + -> (JP.Index, Value) + -> Maybe (JP.Index, NonEmpty err) + validateElem schema (index,x) = (index,) <$> NE.nonEmpty (f schema x) + +-------------------------------------------------- +-- * additionalItems +-------------------------------------------------- + +data AdditionalItems schema + = AdditionalBool Bool + | AdditionalObject schema + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (AdditionalItems schema) where + parseJSON v = fmap AdditionalBool (parseJSON v) + <|> fmap AdditionalObject (parseJSON v) + +instance ToJSON schema => ToJSON (AdditionalItems schema) where + toJSON (AdditionalBool b) = toJSON b + toJSON (AdditionalObject hm) = toJSON hm + +instance Arbitrary schema => Arbitrary (AdditionalItems schema) where + arbitrary = oneof [ AdditionalBool <$> arbitrary + , AdditionalObject <$> arbitrary + ] + +data AdditionalItemsInvalid err + = AdditionalItemsBoolInvalid (NonEmpty (JP.Index, Value)) + | AdditionalItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err)) + deriving (Eq, Show) + +-- | Internal. +-- +-- This is because 'itemsRelated' handles @"additionalItems"@ validation. +additionalItemsVal + :: forall err schema. + (schema -> Value -> [err]) + -> AdditionalItems schema + -> [(JP.Index, Value)] + -- ^ The elements remaining to validate after the ones covered by + -- @"items"@ have been removed. + -> Maybe (AdditionalItemsInvalid err) +additionalItemsVal _ (AdditionalBool True) _ = Nothing +additionalItemsVal _ (AdditionalBool False) xs = + AdditionalItemsBoolInvalid <$> NE.nonEmpty xs +additionalItemsVal f (AdditionalObject subSchema) xs = + let res = mapMaybe + (\(index,x) -> (index,) <$> NE.nonEmpty (f subSchema x)) + xs + in AdditionalItemsObjectInvalid <$> NE.nonEmpty res diff --git a/src/JSONSchema/Validator/Draft4/Number.hs b/src/JSONSchema/Validator/Draft4/Number.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Number.hs @@ -0,0 +1,84 @@ + +module JSONSchema.Validator.Draft4.Number where + +import Import + +import Data.Fixed (mod') +import Data.Scientific (Scientific) + +-------------------------------------------------- +-- * multipleOf +-------------------------------------------------- + +newtype MultipleOf + = MultipleOf { _unMultipleOf :: Scientific } + deriving (Eq, Show) + +instance FromJSON MultipleOf where + parseJSON = withObject "MultipleOf" $ \o -> + MultipleOf <$> o .: "multipleOf" + +data MultipleOfInvalid + = MultipleOfInvalid MultipleOf Scientific + deriving (Eq, Show) + +-- | The spec requires @"multipleOf"@ to be positive. +multipleOfVal :: MultipleOf -> Scientific -> Maybe MultipleOfInvalid +multipleOfVal a@(MultipleOf n) x + | n <= 0 = Nothing + | x `mod'` n /= 0 = Just (MultipleOfInvalid a x) + | otherwise = Nothing + +-------------------------------------------------- +-- * maximum +-------------------------------------------------- + +data Maximum = Maximum + { _maximumExclusive :: Bool + , _maximumValue :: Scientific + } deriving (Eq, Show) + +instance FromJSON Maximum where + parseJSON = withObject "Maximum" $ \o -> Maximum + <$> o .:! "exclusiveMaximum" .!= False + <*> o .: "maximum" + +data MaximumInvalid + = MaximumInvalid Maximum Scientific + deriving (Eq, Show) + +maximumVal + :: Maximum + -> Scientific + -> Maybe MaximumInvalid +maximumVal a@(Maximum exclusive n) x + | exclusive && x >= n = Just (MaximumInvalid a x) + | x > n = Just (MaximumInvalid a x) + | otherwise = Nothing + +-------------------------------------------------- +-- * minimum +-------------------------------------------------- + +data Minimum = Minimum + { _minimumExclusive :: Bool + , _minimumValue :: Scientific + } deriving (Eq, Show) + +instance FromJSON Minimum where + parseJSON = withObject "Minimum" $ \o -> Minimum + <$> o .:! "exclusiveMinimum" .!= False + <*> o .: "minimum" + +data MinimumInvalid + = MinimumInvalid Minimum Scientific + deriving (Eq, Show) + +minimumVal + :: Minimum + -> Scientific + -> Maybe MinimumInvalid +minimumVal a@(Minimum exclusive n) x + | exclusive && x <= n = Just (MinimumInvalid a x) + | x < n = Just (MinimumInvalid a x) + | otherwise = Nothing diff --git a/src/JSONSchema/Validator/Draft4/Object.hs b/src/JSONSchema/Validator/Draft4/Object.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Object.hs @@ -0,0 +1,179 @@ + +module JSONSchema.Validator.Draft4.Object + ( module JSONSchema.Validator.Draft4.Object + , module JSONSchema.Validator.Draft4.Object.Properties + ) where + +import Import + +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T + +import JSONSchema.Validator.Draft4.Object.Properties +import JSONSchema.Validator.Utils + +-------------------------------------------------- +-- * maxProperties +-------------------------------------------------- + +newtype MaxProperties + = MaxProperties { _unMaxProperties :: Int } + deriving (Eq, Show) + +instance FromJSON MaxProperties where + parseJSON = withObject "MaxProperties" $ \o -> + MaxProperties <$> o .: "maxProperties" + +data MaxPropertiesInvalid + = MaxPropertiesInvalid MaxProperties (HashMap Text Value) + deriving (Eq, Show) + +-- | The spec requires @"maxProperties"@ to be non-negative. +maxPropertiesVal + :: MaxProperties + -> HashMap Text Value + -> Maybe MaxPropertiesInvalid +maxPropertiesVal a@(MaxProperties n) x + | n < 0 = Nothing + | HM.size x > n = Just (MaxPropertiesInvalid a x) + | otherwise = Nothing + +-------------------------------------------------- +-- * minProperties +-------------------------------------------------- + +newtype MinProperties + = MinProperties { _unMinProperties :: Int } + deriving (Eq, Show) + +instance FromJSON MinProperties where + parseJSON = withObject "MinProperties" $ \o -> + MinProperties <$> o .: "minProperties" + +data MinPropertiesInvalid + = MinPropertiesInvalid MinProperties (HashMap Text Value) + deriving (Eq, Show) + +-- | The spec requires @"minProperties"@ to be non-negative. +minPropertiesVal + :: MinProperties + -> HashMap Text Value + -> Maybe MinPropertiesInvalid +minPropertiesVal a@(MinProperties n) x + | n < 0 = Nothing + | HM.size x < n = Just (MinPropertiesInvalid a x) + | otherwise = Nothing + +-------------------------------------------------- +-- * required +-------------------------------------------------- + +-- | From the spec: +-- +-- > The value of this keyword MUST be an array. +-- > This array MUST have at least one element. +-- > Elements of this array MUST be strings, and MUST be unique. +newtype Required + = Required { _unRequired :: Set Text } + deriving (Eq, Show) + +instance FromJSON Required where + parseJSON = withObject "Required" $ \o -> + Required <$> o .: "required" + +instance Arbitrary Required where + arbitrary = do + x <- arbitraryText -- Guarantee at least one element. + xs <- (fmap.fmap) T.pack arbitrary + pure . Required . S.fromList $ x:xs + +requiredVal :: Required -> HashMap Text Value -> Maybe () +requiredVal (Required ts) x + -- NOTE: When we no longer need to support GHCs before 7.10 + -- we can use null from Prelude throughout the library + -- instead of specialized versions. + | S.null ts = Nothing + | HM.null (HM.difference hm x) = Nothing + | otherwise = Just () -- TODO + where + hm :: HashMap Text Bool + hm = foldl (\b a -> HM.insert a True b) mempty ts + +-------------------------------------------------- +-- * dependencies +-------------------------------------------------- + +newtype DependenciesValidator schema + = DependenciesValidator + { _unDependenciesValidator :: HashMap Text (Dependency schema) } + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (DependenciesValidator schema) where + parseJSON = withObject "DependenciesValidator" $ \o -> + DependenciesValidator <$> o .: "dependencies" + +data Dependency schema + = SchemaDependency schema + | PropertyDependency (Set Text) + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (Dependency schema) where + parseJSON v = fmap SchemaDependency (parseJSON v) + <|> fmap PropertyDependency (parseJSON v) + +instance ToJSON schema => ToJSON (Dependency schema) where + toJSON (SchemaDependency schema) = toJSON schema + toJSON (PropertyDependency ts) = toJSON ts + +instance Arbitrary schema => Arbitrary (Dependency schema) where + arbitrary = oneof [ SchemaDependency <$> arbitrary + , PropertyDependency <$> arbitrarySetOfText + ] + +data DependencyMemberInvalid err + = SchemaDepInvalid (NonEmpty err) + | PropertyDepInvalid (Set Text) (HashMap Text Value) + deriving (Eq, Show) + +data DependenciesInvalid err + = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err)) + deriving (Eq, Show) + +-- | From the spec: +-- +-- +-- > This keyword's value MUST be an object. +-- > Each value of this object MUST be either an object or an array. +-- > +-- > If the value is an object, it MUST be a valid JSON Schema. +-- > This is called a schema dependency. +-- > +-- > If the value is an array, it MUST have at least one element. +-- > Each element MUST be a string, and elements in the array MUST be unique. +-- > This is called a property dependency. +dependenciesVal + :: forall err schema. + (schema -> Value -> [err]) + -> DependenciesValidator schema + -> HashMap Text Value + -> Maybe (DependenciesInvalid err) +dependenciesVal f (DependenciesValidator hm) x = + let res = HM.mapMaybeWithKey g hm + in if HM.null res + then Nothing + else Just (DependenciesInvalid res) + where + g :: Text -> Dependency schema -> Maybe (DependencyMemberInvalid err) + g k (SchemaDependency schema) + | HM.member k x = SchemaDepInvalid + <$> NE.nonEmpty (f schema (Object x)) + | otherwise = Nothing + g k (PropertyDependency ts) + | HM.member k x && not allPresent = Just (PropertyDepInvalid ts x) + | otherwise = Nothing + where + allPresent :: Bool + allPresent = all (`HM.member` x) ts diff --git a/src/JSONSchema/Validator/Draft4/Object/Properties.hs b/src/JSONSchema/Validator/Draft4/Object/Properties.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/Object/Properties.hs @@ -0,0 +1,209 @@ + +module JSONSchema.Validator.Draft4.Object.Properties where + +import Import + +import qualified Data.Hashable as HA +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Text.Encoding (encodeUtf8) +import qualified JSONPointer as JP +import qualified Text.Regex.PCRE.Heavy as RE + +data PropertiesRelated schema = PropertiesRelated + { _propProperties :: Maybe (HashMap Text schema) + , _propPattern :: Maybe (HashMap Text schema) + , _propAdditional :: Maybe (AdditionalProperties schema) + } deriving (Eq, Show) + +instance FromJSON schema => FromJSON (PropertiesRelated schema) where + parseJSON = withObject "PropertiesRelated" $ \o -> PropertiesRelated + <$> o .:! "properties" + <*> o .:! "patternProperties" + <*> o .:! "additionalProperties" + +emptyProperties :: PropertiesRelated schema +emptyProperties = PropertiesRelated + { _propProperties = Nothing + , _propPattern = Nothing + , _propAdditional = Nothing + } + +data AdditionalProperties schema + = AdditionalPropertiesBool Bool + | AdditionalPropertiesObject schema + deriving (Eq, Show) + +instance FromJSON schema => FromJSON (AdditionalProperties schema) where + parseJSON v = fmap AdditionalPropertiesBool (parseJSON v) + <|> fmap AdditionalPropertiesObject (parseJSON v) + +instance ToJSON schema => ToJSON (AdditionalProperties schema) where + toJSON (AdditionalPropertiesBool b) = toJSON b + toJSON (AdditionalPropertiesObject hm) = toJSON hm + +instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where + arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary + , AdditionalPropertiesObject <$> arbitrary + ] + +-- | A glorified @type@ alias. +newtype Regex + = Regex { _unRegex :: Text } + deriving (Eq, Show, Generic) + +instance HA.Hashable Regex + +-- NOTE: We'd like to enforce that at least one error exists here. +data PropertiesRelatedInvalid err = PropertiesRelatedInvalid + { _prInvalidProperties :: HashMap Text [err] + , _prInvalidPattern :: HashMap (Regex, JP.Key) [err] + , _prInvalidAdditional :: Maybe (APInvalid err) + } deriving (Eq, Show) + +data APInvalid err + = APBoolInvalid (HashMap Text Value) + | APObjectInvalid (HashMap Text (NonEmpty err)) + deriving (Eq, Show) + +-- | First @"properties"@ and @"patternProperties"@ are run simultaneously +-- on the data, then @"additionalProperties"@ is run on the remainder. +propertiesRelatedVal + :: forall err schema. + (schema -> Value -> [err]) + -> PropertiesRelated schema + -> HashMap Text Value + -> Maybe (PropertiesRelatedInvalid err) +propertiesRelatedVal f props x + | all null (HM.elems propFailures) + && all null (HM.elems patFailures) + && isNothing addFailures = Nothing + | otherwise = + Just PropertiesRelatedInvalid + { _prInvalidProperties = propFailures + , _prInvalidPattern = patFailures + , _prInvalidAdditional = addFailures + } + where + propertiesHm :: HashMap Text schema + propertiesHm = fromMaybe mempty (_propProperties props) + + patHm :: HashMap Text schema + patHm = fromMaybe mempty (_propPattern props) + + propAndUnmatched :: (HashMap Text [err], Remaining) + propAndUnmatched = ( HM.intersectionWith f propertiesHm x + , Remaining (HM.difference x propertiesHm) + ) + + (propFailures, propRemaining) = propAndUnmatched + + patAndUnmatched :: (HashMap (Regex, JP.Key) [err], Remaining) + patAndUnmatched = patternAndUnmatched f patHm x + + (patFailures, patRemaining) = patAndUnmatched + + finalRemaining :: Remaining + finalRemaining = Remaining (HM.intersection (_unRemaining patRemaining) + (_unRemaining propRemaining)) + + addFailures :: Maybe (APInvalid err) + addFailures = (\addProp -> additionalProperties f addProp finalRemaining) + =<< _propAdditional props + +-- | Internal. +newtype Remaining + = Remaining { _unRemaining :: HashMap Text Value } + +-- | Internal. +patternAndUnmatched + :: forall err schema. + (schema -> Value -> [err]) + -> HashMap Text schema + -> HashMap Text Value + -> (HashMap (Regex, JP.Key) [err], Remaining) +patternAndUnmatched f patPropertiesHm x = + (HM.foldlWithKey' runMatches mempty perhapsMatches, remaining) + where + -- @[(Regex, schema)]@ will have one item per match. + perhapsMatches :: HashMap Text ([(Regex, schema)], Value) + perhapsMatches = + HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x + where + matchingSchemas + :: HashMap Text schema + -> HashMap Text ([(Regex, schema)], Value) + -> Text + -> Value + -> HashMap Text ([(Regex, schema)], Value) + matchingSchemas subSchemas acc k v = + HM.insert k + (HM.foldlWithKey' (checkKey k) mempty subSchemas, v) + acc + + checkKey + :: Text + -> [(Regex, schema)] + -> Text + -> schema + -> [(Regex, schema)] + checkKey k acc r subSchema = + case RE.compileM (encodeUtf8 r) mempty of + Left _ -> acc + Right re -> if k RE.=~ re + then (Regex r, subSchema) : acc + else acc + + runMatches + :: HashMap (Regex, JP.Key) [err] + -> Text + -> ([(Regex, schema)], Value) + -> HashMap (Regex, JP.Key) [err] + runMatches acc k (matches,v) = + foldr runMatch acc matches + where + runMatch + :: (Regex, schema) + -> HashMap (Regex, JP.Key) [err] + -> HashMap (Regex, JP.Key) [err] + runMatch (r,schema) = HM.insert (r, JP.Key k) (f schema v) + + remaining :: Remaining + remaining = Remaining . fmap snd . HM.filter (null . fst) $ perhapsMatches + +-- Internal. +additionalProperties + :: forall err schema. + (schema -> Value -> [err]) + -> AdditionalProperties schema + -> Remaining + -> Maybe (APInvalid err) +additionalProperties f a x = + case a of + AdditionalPropertiesBool b -> + APBoolInvalid <$> additionalPropertiesBool b x + AdditionalPropertiesObject b -> + APObjectInvalid <$> additionalPropertiesObject f b x + +-- | Internal. +additionalPropertiesBool + :: Bool + -> Remaining + -> Maybe (HashMap Text Value) +additionalPropertiesBool True _ = Nothing +additionalPropertiesBool False (Remaining x) + | HM.size x > 0 = Just x + | otherwise = Nothing + +-- | Internal. +additionalPropertiesObject + :: forall err schema. + (schema -> Value -> [err]) + -> schema + -> Remaining + -> Maybe (HashMap Text (NonEmpty err)) +additionalPropertiesObject f schema (Remaining x) = + let errs = HM.mapMaybe (NE.nonEmpty . f schema) x + in if HM.null errs + then Nothing + else Just errs diff --git a/src/JSONSchema/Validator/Draft4/String.hs b/src/JSONSchema/Validator/Draft4/String.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Draft4/String.hs @@ -0,0 +1,79 @@ + +module JSONSchema.Validator.Draft4.String where + +import Import + +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Text.Regex.PCRE.Heavy as RE + +-------------------------------------------------- +-- * maxLength +-------------------------------------------------- + +newtype MaxLength + = MaxLength { _unMaxLength :: Int } + deriving (Eq, Show) + +instance FromJSON MaxLength where + parseJSON = withObject "MaxLength" $ \o -> + MaxLength <$> o .: "maxLength" + +data MaxLengthInvalid + = MaxLengthInvalid MaxLength Text + deriving (Eq, Show) + +-- | The spec requires @"maxLength"@ to be non-negative. +maxLengthVal :: MaxLength -> Text -> Maybe MaxLengthInvalid +maxLengthVal a@(MaxLength n) x + | n <= 0 = Nothing + | T.length x > n = Just (MaxLengthInvalid a x) + | otherwise = Nothing + +-------------------------------------------------- +-- * minLength +-------------------------------------------------- + +newtype MinLength + = MinLength { _unMinLength :: Int } + deriving (Eq, Show) + +instance FromJSON MinLength where + parseJSON = withObject "MinLength" $ \o -> + MinLength <$> o .: "minLength" + +data MinLengthInvalid + = MinLengthInvalid MinLength Text + deriving (Eq, Show) + +-- | The spec requires @"minLength"@ to be non-negative. +minLengthVal :: MinLength -> Text -> Maybe MinLengthInvalid +minLengthVal a@(MinLength n) x + | n <= 0 = Nothing + | T.length x < n = Just (MinLengthInvalid a x) + | otherwise = Nothing + +-------------------------------------------------- +-- * pattern +-------------------------------------------------- + +newtype PatternValidator + = PatternValidator { _unPatternValidator :: Text } + deriving (Eq, Show) + +instance FromJSON PatternValidator where + parseJSON = withObject "PatternValidator" $ \o -> + PatternValidator <$> o .: "pattern" + +data PatternInvalid + = PatternNotRegex -- TODO: let these pass successfully? + | PatternInvalid PatternValidator Text + deriving (Eq, Show) + +patternVal :: PatternValidator -> Text -> Maybe PatternInvalid +patternVal a@(PatternValidator t) x = + case RE.compileM (encodeUtf8 t) mempty of + Left _ -> Just PatternNotRegex + Right re -> if x RE.=~ re + then Nothing + else Just (PatternInvalid a x) diff --git a/src/JSONSchema/Validator/Reference.hs b/src/JSONSchema/Validator/Reference.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Reference.hs @@ -0,0 +1,79 @@ +-- | JSON Reference is described here: +-- +-- +-- And is extended for JSON Schema here: +-- + +module JSONSchema.Validator.Reference where + +import Import + +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified JSONPointer as JP +import Network.HTTP.Types.URI (urlDecode) +import System.FilePath ((), dropFileName) + +-- | TODO: Replace these with actual URI data types. +type URIBase = Maybe Text +type URIBaseAndFragment = (Maybe Text, Maybe Text) + +updateResolutionScope :: URIBase -> Maybe Text -> URIBase +updateResolutionScope mScope idKeyword + | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t + | otherwise = mScope + +resolveReference :: URIBase -> Text -> URIBaseAndFragment +resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t + +resolveFragment + :: (FromJSON schema, ToJSON schema) + => Maybe Text + -> schema + -> Maybe schema +resolveFragment Nothing schema = Just schema +resolveFragment (Just pointer) schema = do + let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer + p <- either (const Nothing) Just (JP.unescape urlDecoded) + x <- either (const Nothing) Just (JP.resolve p (toJSON schema)) + case fromJSON x of + Error _ -> Nothing + Success schema' -> Just schema' + +-------------------------------------------------- +-- * Helpers +-------------------------------------------------- + +isRemoteReference :: Text -> Bool +isRemoteReference = T.isInfixOf "://" + +baseAndFragment :: Text -> URIBaseAndFragment +baseAndFragment = f . T.splitOn "#" + where + f :: [Text] -> URIBaseAndFragment + f [x] = (g x, Nothing) + f [x,y] = (g x, g y) + f _ = (Nothing, Nothing) + + g "" = Nothing + g x = Just x + +resolveScopeAgainst :: Maybe Text -> Text -> Text +resolveScopeAgainst Nothing t = t +resolveScopeAgainst (Just scope) t + | isRemoteReference t = t + | otherwise = smartAppend + where + -- There shouldn't be a fragment at the end of a scope URI, + -- but just in case a user leaves one in we want to be sure + -- to cut it off before appending. + smartAppend :: Text + smartAppend = + case baseAndFragment scope of + (Just base,_) -> + case T.unpack t of + -- We want "/foo" and "#/bar" to combine into + -- "/foo#/bar" not "/foo/#/bar". + '#':_ -> base <> t + _ -> T.pack (dropFileName (T.unpack base) T.unpack t) + _ -> t diff --git a/src/JSONSchema/Validator/Types.hs b/src/JSONSchema/Validator/Types.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Types.hs @@ -0,0 +1,23 @@ + +module JSONSchema.Validator.Types where + +import Import + +import Data.Profunctor (Profunctor(..)) + +data Validator schema val err = Validator + { _embedded :: val -> ([schema], [schema]) + -- ^ The first list is embedded schemas that validate the same piece + -- of data this schema validates (such as schemas embedded in 'allOf'). + -- The second is embedded schemas that validate a subset of that data + -- (such as the schemas embedded in 'items'). + -- + -- This is done to allow static detection of loops, though this isn't + -- implemented yet (though the Draft4 code does do live loop detection + -- during validation). + , _validate :: val -> Value -> [err] + } deriving Functor + +instance Profunctor (Validator schema) where + lmap f (Validator a b) = Validator (lmap f a) (lmap f b) + rmap = fmap diff --git a/src/JSONSchema/Validator/Utils.hs b/src/JSONSchema/Validator/Utils.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validator/Utils.hs @@ -0,0 +1,135 @@ + +module JSONSchema.Validator.Utils where + +import Import + +import Control.Monad (fail) +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE +import Data.Scientific (Scientific, fromFloatDigits) +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Vector as V + +-------------------------------------------------- +-- * QuickCheck +-------------------------------------------------- + +arbitraryText :: Gen Text +arbitraryText = T.pack <$> arbitrary + +arbitraryScientific :: Gen Scientific +arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary + +arbitraryPositiveScientific :: Gen Scientific +arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific) + . getPositive + <$> arbitrary + +newtype ArbitraryValue + = ArbitraryValue { _unArbitraryValue :: Value } + deriving (Eq, Show) + +instance Arbitrary ArbitraryValue where + arbitrary = ArbitraryValue <$> sized f + where + f :: Int -> Gen Value + f n | n <= 1 = oneof nonRecursive + | otherwise = oneof $ + fmap (Array . V.fromList) (traverse (const (f (n `div` 10))) + =<< (arbitrary :: Gen [()])) + : fmap (Object . HM.fromList) (traverse (const (g (n `div` 10))) + =<< (arbitrary :: Gen [()])) + : nonRecursive + + g :: Int -> Gen (Text, Value) + g n = (,) <$> arbitraryText <*> f n + + nonRecursive :: [Gen Value] + nonRecursive = + [ pure Null + , Bool <$> arbitrary + , String <$> arbitraryText + , Number <$> arbitraryScientific + ] + +arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a) +arbitraryHashMap = HM.fromList . fmap (first T.pack) <$> arbitrary + +arbitrarySetOfText :: Gen (Set Text) +arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary + +newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a } + +instance FromJSON a => FromJSON (NonEmpty' a) where + parseJSON v = do + xs <- parseJSON v + case NE.nonEmpty xs of + Nothing -> fail "Must have at least one item." + Just ne -> pure (NonEmpty' ne) + +instance ToJSON a => ToJSON (NonEmpty' a) where + toJSON = toJSON . NE.toList . _unNonEmpty' + +instance Arbitrary a => Arbitrary (NonEmpty' a) where + arbitrary = do + xs <- arbitrary + case NE.nonEmpty xs of + Nothing -> NonEmpty' . pure <$> arbitrary + Just ne -> pure (NonEmpty' ne) + +-------------------------------------------------- +-- * allUniqueValues +-------------------------------------------------- + +allUniqueValues :: Vector Value -> Bool +allUniqueValues = allUnique . fmap OrdValue . V.toList + +-- NOTE: When we no longer support GHC 7.8 we can generalize +-- allUnique to work on any Foldable and remove this function. +allUniqueValues' :: NonEmpty Value -> Bool +allUniqueValues' = allUnique . fmap OrdValue . NE.toList + +allUnique :: (Ord a) => [a] -> Bool +allUnique xs = S.size (S.fromList xs) == length xs + +-- | OrdValue's Ord instance needs benchmarking, but it allows us to +-- use our 'allUnique' function instead of O(n^2) nub, so it's probably +-- worth it. +newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq + +instance Ord OrdValue where + (OrdValue Null) `compare` (OrdValue Null) = EQ + (OrdValue Null) `compare` _ = LT + _ `compare` (OrdValue Null) = GT + + (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y + (OrdValue (Bool _)) `compare` _ = LT + _ `compare` (OrdValue (Bool _)) = GT + + (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y + (OrdValue (Number _)) `compare` _ = LT + _ `compare` (OrdValue (Number _)) = GT + + (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y + (OrdValue (String _)) `compare` _ = LT + _ `compare` (OrdValue (String _)) = GT + + (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) = + (OrdValue <$> xs) `compare` (OrdValue <$> ys) + (OrdValue (Array _)) `compare` _ = LT + _ `compare` (OrdValue (Array _)) = GT + + (OrdValue (Object x)) `compare` (OrdValue (Object y)) = + HM.toList (OrdValue <$> x) `compare` HM.toList (OrdValue <$> y) + +-------------------------------------------------- +-- * other +-------------------------------------------------- + +fromJSONEither :: FromJSON a => Value -> Either Text a +fromJSONEither a = + case fromJSON a of + Error e -> Left (T.pack e) + Success b -> Right b diff --git a/test/Local.hs b/test/Local.hs --- a/test/Local.hs +++ b/test/Local.hs @@ -4,15 +4,15 @@ import Protolude import Data.Aeson -import qualified Data.List.NonEmpty as NE -import qualified System.Timeout as TO +import qualified Data.List.NonEmpty as NE +import qualified System.Timeout as TO import Test.Hspec -import Test.QuickCheck (property) +import Test.QuickCheck (property) -import qualified Data.JsonSchema.Draft4 as D4 -import Data.JsonSchema.Fetch (ReferencedSchemas(..), - URISchemaMap(..)) -import qualified Data.JsonSchema.Types as JT +import qualified JSONSchema.Draft4 as D4 +import JSONSchema.Fetch (ReferencedSchemas(..), + URISchemaMap(..)) +import qualified JSONSchema.Types as JT import qualified Local.Failure import qualified Local.Validation import qualified Local.Reference @@ -46,7 +46,7 @@ describe "Examples" exampleTests describe "QuickCheck" quickCheckTests describe "Failure" Local.Failure.spec - describe "Data.Validator.Reference" Local.Reference.spec + describe "JSONSchema.Validator.Reference" Local.Reference.spec describe "Supplementary validation tests written in Haskell" Local.Validation.spec diff --git a/test/Local/Failure.hs b/test/Local/Failure.hs --- a/test/Local/Failure.hs +++ b/test/Local/Failure.hs @@ -8,9 +8,9 @@ import qualified Data.Vector as V import qualified JSONPointer as JP -import Data.JsonSchema.Draft4 -import qualified Data.JsonSchema.Draft4.Spec as Spec -import qualified Data.Validator.Draft4 as D4 +import JSONSchema.Draft4 +import qualified JSONSchema.Draft4.Spec as Spec +import qualified JSONSchema.Validator.Draft4 as VAL spec :: Spec spec = do @@ -21,9 +21,9 @@ itemsArray :: Expectation itemsArray = failures `shouldBe` - [ FailureItems (D4.ItemsArrayInvalid ( + [ FailureItems (VAL.ItemsArrayInvalid ( pure ( JP.Index 0 - , pure (FailureUniqueItems (D4.UniqueItemsInvalid + , pure (FailureUniqueItems (VAL.UniqueItemsInvalid (V.fromList [Null, Null]) )) ) @@ -35,7 +35,7 @@ schema :: Schema schema = emptySchema - { _schemaItems = Just $ D4.ItemsArray + { _schemaItems = Just $ VAL.ItemsArray [emptySchema { _schemaUniqueItems = Just True }] } @@ -51,9 +51,9 @@ itemsObject :: Expectation itemsObject = failures `shouldBe` - [ FailureItems (D4.ItemsObjectInvalid ( + [ FailureItems (VAL.ItemsObjectInvalid ( pure ( JP.Index 1 - , pure (FailureUniqueItems (D4.UniqueItemsInvalid + , pure (FailureUniqueItems (VAL.UniqueItemsInvalid (V.fromList [Null, Null]) )) ) @@ -65,7 +65,7 @@ schema :: Schema schema = emptySchema - { _schemaItems = Just $ D4.ItemsObject + { _schemaItems = Just $ VAL.ItemsObject (emptySchema { _schemaUniqueItems = Just True }) } @@ -81,9 +81,9 @@ loopRef :: Expectation loopRef = failures `shouldBe` - [ FailureRef (D4.RefLoop + [ FailureRef (VAL.RefLoop "#" - (D4.VisitedSchemas [(Nothing, Nothing)]) + (VAL.VisitedSchemas [(Nothing, Nothing)]) (Nothing, Nothing) ) ] diff --git a/test/Local/Reference.hs b/test/Local/Reference.hs --- a/test/Local/Reference.hs +++ b/test/Local/Reference.hs @@ -5,7 +5,7 @@ import Test.Hspec -import Data.Validator.Reference +import JSONSchema.Validator.Reference spec :: Spec spec = do diff --git a/test/Local/Validation.hs b/test/Local/Validation.hs --- a/test/Local/Validation.hs +++ b/test/Local/Validation.hs @@ -1,18 +1,17 @@ module Local.Validation where -import Protolude hiding (msg) +import Protolude hiding (msg) import Data.Aeson -import qualified Data.Aeson as AE -import qualified Data.HashMap.Strict as HM -import Data.String (String) +import qualified Data.Aeson as AE +import qualified Data.HashMap.Strict as HM +import Data.String (String) import Test.Hspec -import Data.JsonSchema.Draft4 -import qualified Data.JsonSchema.Types as JT - -import qualified AlternateSchema as AS +import JSONSchema.Draft4 +import qualified JSONSchema.Types as JT +import qualified AlternateSchema as AS spec :: Spec spec = do diff --git a/test/Remote.hs b/test/Remote.hs --- a/test/Remote.hs +++ b/test/Remote.hs @@ -10,10 +10,10 @@ import Network.Wai.Handler.Warp (run) import Test.Hspec -import qualified Data.JsonSchema.Draft4 as D4 -import Data.JsonSchema.Fetch (ReferencedSchemas(..), - URISchemaMap(..)) -import qualified Data.JsonSchema.Types as JT +import qualified JSONSchema.Draft4 as D4 +import JSONSchema.Fetch (ReferencedSchemas(..), + URISchemaMap(..)) +import qualified JSONSchema.Types as JT import Shared -- Examples