module Data.JsonSchema.Draft4.Internal where
import Data.Aeson
import qualified Data.HashMap.Strict as H
import qualified Data.List.NonEmpty as N
import Data.Maybe (catMaybes, fromMaybe, isJust,
maybeToList)
import Data.Scientific
import Data.JsonSchema.Draft4.Failure
import Data.JsonSchema.Draft4.Schema
import Data.JsonSchema.Fetch (SchemaCache(..),
SchemaContext(..))
import qualified Data.Validator.Draft4.Any as AN
import qualified Data.Validator.Draft4.Array as AR
import qualified Data.Validator.Draft4.Number as NU
import qualified Data.Validator.Draft4.Object as OB
import qualified Data.Validator.Draft4.String as ST
import Data.Validator.Failure (modFailure, setFailure)
import qualified Data.Validator.Failure as FR
import Data.Validator.Reference (newResolutionScope)
import Import
import Prelude hiding (concat)
embedded :: Schema -> [Schema]
embedded schema = concat
[ f _schemaItems
(\x -> case x of
AR.ItemsObject s -> pure s
AR.ItemsArray ss -> ss
)
, f _schemaAdditionalItems
(\x -> case x of
AR.AdditionalObject s -> pure s
_ -> mempty
)
, f _schemaDependencies (catMaybes . fmap checkDependency . H.elems)
, f _schemaProperties H.elems
, f _schemaPatternProperties H.elems
, f _schemaAdditionalProperties
(\x -> case x of
OB.AdditionalPropertiesObject s -> pure s
_ -> mempty
)
, f _schemaAllOf N.toList
, f _schemaAnyOf N.toList
, f _schemaOneOf N.toList
, f _schemaNot pure
, f _schemaDefinitions H.elems
]
where
f :: (Schema -> Maybe a) -> (a -> [Schema]) -> [Schema]
f field nextLevelEmbedded = maybe mempty nextLevelEmbedded (field schema)
checkDependency :: OB.Dependency Schema -> Maybe Schema
checkDependency (OB.PropertyDependency _) = Nothing
checkDependency (OB.SchemaDependency s) = Just s
runValidate
:: SchemaCache Schema
-> SchemaContext Schema
-> Value
-> [Failure]
runValidate = (fmap.fmap.fmap.fmap) specializeForDraft4 validateAny
validateAny
:: SchemaCache Schema
-> SchemaContext Schema
-> Value
-> [FR.Failure ValidatorChain]
validateAny cache sc x = concat
[ f _schemaEnum (setFailure Enum) (fmap maybeToList . AN.enumVal)
, f _schemaType (setFailure TypeValidator) (fmap maybeToList . AN.typeVal)
, f _schemaAllOf (modFailure AllOf) (AN.allOf recurse)
, f _schemaAnyOf (setFailure AnyOf) (fmap maybeToList . AN.anyOf recurse)
, f _schemaOneOf (setFailure OneOf) (fmap maybeToList . AN.oneOf recurse)
, f _schemaNot (setFailure NotValidator) (fmap maybeToList . AN.notVal recurse)
, refFailures
] <> specificValidators
where
specificValidators :: [FR.Failure ValidatorChain]
specificValidators =
case x of
Number y -> validateNumber (_scSchema sc) y
String y -> validateString (_scSchema sc) y
Array y -> validateArray cache sc y
Object y -> validateObject cache sc y
_ -> mempty
f = runSingle (_scSchema sc) x
recurse = descendNextLevel cache sc
refFailures :: [FR.Failure ValidatorChain]
refFailures =
case _schemaRef (_scSchema sc) of
Nothing -> mempty
Just reference ->
maybe [FR.Failure RefResolution (toJSON reference) mempty]
(fmap (modFailure Ref))
$ AN.ref scope
getReference
(\a b -> validateAny cache (SchemaContext a b))
reference
x
where
scope :: Maybe Text
scope = newResolutionScope (_scURI sc) (_schemaId (_scSchema sc))
getReference :: Maybe Text -> Maybe Schema
getReference Nothing = Just (_startingSchema cache)
getReference (Just t) = H.lookup t (_cachedSchemas cache)
validateString
:: Schema
-> Text
-> [FR.Failure ValidatorChain]
validateString schema x = concat
[ f _schemaMaxLength (setFailure MaxLength) (fmap maybeToList . ST.maxLength)
, f _schemaMinLength (setFailure MinLength) (fmap maybeToList . ST.minLength)
, f _schemaPattern (setFailure PatternValidator) (fmap maybeToList . ST.patternVal)
]
where
f = runSingle schema x
validateNumber
:: Schema
-> Scientific
-> [FR.Failure ValidatorChain]
validateNumber schema x = concat
[ f _schemaMultipleOf (setFailure MultipleOf) (fmap maybeToList . NU.multipleOf)
, f _schemaMaximum
(modFailure fMax)
( fmap maybeToList
. NU.maximumVal (fromMaybe False (_schemaExclusiveMaximum schema))
)
, f _schemaMinimum
(modFailure fMin)
( fmap maybeToList
. NU.minimumVal (fromMaybe False (_schemaExclusiveMinimum schema))
)
]
where
f = runSingle schema x
fMax NU.Maximum = Maximum
fMax NU.ExclusiveMaximum = ExclusiveMaximum
fMin NU.Minimum = Minimum
fMin NU.ExclusiveMinimum = ExclusiveMinimum
validateArray
:: SchemaCache Schema
-> SchemaContext Schema
-> Vector Value
-> [FR.Failure ValidatorChain]
validateArray cache (SchemaContext mUri schema) x = concat
[ f _schemaMaxItems (setFailure MaxItems) (fmap maybeToList . AR.maxItems)
, f _schemaMinItems (setFailure MinItems) (fmap maybeToList . AR.minItems)
, f _schemaUniqueItems (setFailure UniqueItems) (fmap maybeToList . AR.uniqueItems)
, f _schemaItems
(modFailure fItems)
(AR.items recurse (_schemaAdditionalItems schema))
]
where
f = runSingle schema x
recurse = descendNextLevel cache (SchemaContext mUri schema)
fItems (AR.Items err) = Items err
fItems AR.AdditionalItemsBoolFailure = AdditionalItemsBool
fItems (AR.AdditionalItemsObjectFailure err) = AdditionalItemsObject err
validateObject
:: SchemaCache Schema
-> SchemaContext Schema
-> HashMap Text Value
-> [FR.Failure ValidatorChain]
validateObject cache (SchemaContext mUri schema) x = concat
[ f _schemaMaxProperties (setFailure MaxProperties) (fmap maybeToList . OB.maxProperties)
, f _schemaMinProperties (setFailure MinProperties) (fmap maybeToList . OB.minProperties)
, f _schemaRequired (setFailure Required) (fmap maybeToList . OB.required)
, f _schemaDependencies (modFailure fDeps) (OB.dependencies recurse)
, f _schemaProperties
(modFailure fProp)
(OB.properties recurse
(_schemaPatternProperties schema)
(_schemaAdditionalProperties schema))
, f _schemaPatternProperties
(modFailure fPatProp)
(case _schemaProperties schema of
Just _ -> const (const mempty)
Nothing -> OB.patternProperties recurse (_schemaAdditionalProperties schema))
, f _schemaAdditionalProperties
(modFailure fAddProp)
(if isJust (_schemaProperties schema) || isJust (_schemaPatternProperties schema)
then const (const mempty)
else OB.additionalProperties recurse)
]
where
f = runSingle schema x
recurse = descendNextLevel cache (SchemaContext mUri schema)
fDeps (OB.SchemaDependencyFailure err) = SchemaDependency err
fDeps OB.PropertyDependencyFailure = PropertyDependency
fProp (OB.PropertiesFailure err) = Properties err
fProp (OB.PropPatternFailure err) = PatternProperties err
fProp (OB.PropAdditionalFailure a) =
case a of
OB.APBoolFailure -> AdditionalPropertiesBool
OB.APObjectFailure err -> AdditionalPropertiesObject err
fPatProp (OB.PPFailure err) = PatternProperties err
fPatProp (OB.PPAdditionalPropertiesFailure a) =
case a of
OB.APBoolFailure -> AdditionalPropertiesBool
OB.APObjectFailure err -> AdditionalPropertiesObject err
fAddProp OB.APBoolFailure = AdditionalPropertiesBool
fAddProp (OB.APObjectFailure err) = AdditionalItemsObject err
descendNextLevel
:: SchemaCache Schema
-> SchemaContext Schema
-> Schema
-> Value
-> [FR.Failure ValidatorChain]
descendNextLevel cache (SchemaContext mUri schema) =
validateAny cache . SchemaContext scope
where
scope :: Maybe Text
scope = newResolutionScope mUri (_schemaId schema)
runSingle
:: Schema
-> dta
-> (Schema -> Maybe val)
-> (err -> FR.Failure ValidatorChain)
-> (val -> dta -> [err])
-> [FR.Failure ValidatorChain]
runSingle schema dta field modifyError validate =
maybe mempty (\val -> modifyError <$> validate val dta) (field schema)