Spec.hs

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)