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