Draft4.hs

{-# LANGUAGE TemplateHaskell #-}

module Data.JsonSchema.Draft4 where

import qualified Data.ByteString.Lazy           as LBS
import           Data.FileEmbed
import qualified Data.HashMap.Strict            as H

import           Data.JsonSchema.Core
import           Data.JsonSchema.Draft4.Any
import qualified Data.JsonSchema.Draft4.Arrays as AR
import qualified Data.JsonSchema.Draft4.Numbers as NU
import qualified Data.JsonSchema.Draft4.Objects as OB
import           Data.JsonSchema.Draft4.Strings
import           Data.JsonSchema.Helpers
import           Import

data Draft4Failure
  = MultipleOf

  | Maximum
  | ExclusiveMaximum

  | Minimum
  | ExclusiveMinimum

  | MaxLength
  | MinLength
  | Pattern

  | Items Draft4Failure
  | AdditionalItemsBool
  | AdditionalItemsObject Draft4Failure

  | MaxItems
  | MinItems
  | UniqueItems
  | MaxProperties
  | MinProperties
  | Required

  | Properties Draft4Failure
  | PatternProperties Draft4Failure
  | AdditionalPropertiesBool
  | AdditionalPropertiesObject Draft4Failure

  | SchemaDependency Draft4Failure
  | PropertyDependency

  | Enum
  | TypeValidator
  | AllOf Draft4Failure
  | AnyOf
  | OneOf
  | NotValidator
  | Ref Draft4Failure
  deriving (Eq, Show, Read)

draft4 :: Spec Draft4Failure
draft4 = Spec $ H.fromList
  [ ("$ref"                , ValSpec noEm             (modifyName Ref           ref))
  , ("multipleOf"          , ValSpec noEm             (giveName   MultipleOf    NU.multipleOf))
  , ("maximum"             , ValSpec noEm             (modifyName fMax          NU.maximumVal))
  , ("minimum"             , ValSpec noEm             (modifyName fMin          NU.minimumVal))
  , ("maxLength"           , ValSpec noEm             (giveName   MaxLength     maxLength))
  , ("minLength"           , ValSpec noEm             (giveName   MinLength     minLength))
  , ("pattern"             , ValSpec noEm             (giveName   Pattern       pattern))
  , ("additionalItems"     , ValSpec objEmbed         neverBuild) -- Handled by items.
  , ("items"               , ValSpec objOrArrayEmbed  (modifyName fItems        AR.items))
  , ("maxItems"            , ValSpec noEm             (giveName   MaxItems      AR.maxItems))
  , ("minItems"            , ValSpec noEm             (giveName   MinItems      AR.minItems))
  , ("uniqueItems"         , ValSpec noEm             (giveName   UniqueItems   AR.uniqueItems))
  , ("maxProperties"       , ValSpec noEm             (giveName   MaxProperties OB.maxProperties))
  , ("minProperties"       , ValSpec noEm             (giveName   MinProperties OB.minProperties))
  , ("required"            , ValSpec noEm             (giveName   Required      OB.required))
  , ("properties"          , ValSpec objMembersEmbed  (modifyName fProp         OB.properties))
  , ("patternProperties"   , ValSpec objMembersEmbed  (modifyName fPatProp      OB.patternProperties))
  , ("additionalProperties", ValSpec objEmbed         (modifyName fAddProp      OB.additionalProperties))
  , ("dependencies"        , ValSpec objMembersEmbed  (modifyName fDeps         OB.dependencies))
  , ("enum"                , ValSpec noEm             (giveName   Enum          enum))
  , ("type"                , ValSpec noEm             (giveName   TypeValidator typeValidator))
  , ("allOf"               , ValSpec arrayEmbed       (modifyName AllOf         allOf))
  , ("anyOf"               , ValSpec arrayEmbed       (giveName   AnyOf         anyOf))
  , ("oneOf"               , ValSpec arrayEmbed       (giveName   OneOf         oneOf))
  , ("not"                 , ValSpec objEmbed         (giveName   NotValidator  notValidator))
  , ("definitions"         , ValSpec objMembersEmbed  neverBuild) -- Just contains referenceable schemas.
  ]
  where
    fMax NU.Maximum = Maximum
    fMax NU.ExclusiveMaximum = ExclusiveMaximum

    fMin NU.Minimum = Minimum
    fMin NU.ExclusiveMinimum = ExclusiveMinimum

    fItems (AR.Items err) = Items err
    fItems AR.AdditionalItemsBool = AdditionalItemsBool
    fItems (AR.AdditionalItemsObject err) = AdditionalItemsObject err

    fProp (OB.Properties err) = Properties err
    fProp (OB.PropPattern err) = PatternProperties err
    fProp (OB.PropAdditional OB.AdditionalPropertiesBool) = AdditionalPropertiesBool
    fProp (OB.PropAdditional (OB.AdditionalPropertiesObject err)) = AdditionalPropertiesObject err

    fPatProp (OB.PatternProperties err) = PatternProperties err
    fPatProp (OB.PatternAdditional OB.AdditionalPropertiesBool) = AdditionalPropertiesBool
    fPatProp (OB.PatternAdditional (OB.AdditionalPropertiesObject err)) = AdditionalPropertiesObject err

    fAddProp OB.AdditionalPropertiesBool = AdditionalPropertiesBool
    fAddProp (OB.AdditionalPropertiesObject err) = AdditionalItemsObject err

    fDeps (OB.SchemaDependency err) = SchemaDependency err
    fDeps OB.PropertyDependency = PropertyDependency

-- | Check if a 'RawSchema' is valid Draft 4 schema.
--
-- This is just a convenience function built by preloading 'validate'
-- with the spec schema that describes valid Draft 4 schemas.
--
-- NOTE: It's not actually required to run 'isValidSchema' on
-- prospective draft 4 schemas at all. However, it's a good way to
-- catch unintentional mistakes in schema documents.
isValidSchema :: RawSchema -> [ValidationFailure Draft4Failure]
isValidSchema r =
  case decode . LBS.fromStrict $ $(embedFile "draft4.json") of
    Nothing -> error "Schema decode failed (this should never happen)"
    Just s  -> validate (compile draft4 H.empty $ RawSchema "" s) $ Object (_rsObject r)

-- | Check that a 'RawSchema' conforms to the JSON Schema Draft 4
-- master schema document. Compile it if it does.
--
-- This is just a convenience function built by combining
-- 'isValidSchema' and 'compile'.
--
-- NOTE: It's not actually required to run 'isValidSchema' on
-- prospective draft 4 schemas at all.
compileDraft4 :: Graph -> RawSchema -> Either [ValidationFailure Draft4Failure] (Schema Draft4Failure)
compileDraft4 g r =
  case isValidSchema r of
    []   -> Right (compile draft4 g r)
    errs -> Left errs