diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Changelog +## 0.3.0.0 +- Add value-directed schema construction: a structured `Schema` type (with `Field`, + `AdditionalProperties`, and `SchemaDocument`) plus `schemaToValue` / + `schemaDocumentToValue` renderers, re-exported from `Data.JSON.JSONSchema`. Build a + schema from runtime values when your "types" are data rather than Haskell types. + The `SRaw` constructor is an escape hatch for embedding an arbitrary schema `Value` + (any keyword outside the structured subset) at any node. +- Expose the detailed-error validation API through `Data.JSON.JSONSchema`: + `validate`, `validateWithErrors`, and `ValidationError(..)` are now re-exported + alongside `validateJSONSchema` (fixes the README's broken `JSONSchema.Validation` + import; resolves #1). +- Fix derived schemas for non-record products (tuples): emit `minItems`/`maxItems` + to pin the exact array length. Previously only `items: false` was emitted, which + caps the upper bound but wrongly accepted arrays shorter than the constructor's + arity. This changes the generated schema for such types (hence the major bump). + ## 0.2.0.1 - Widen dependency bounds to support GHC 9.12.2. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # jsonschema +[![Hackage](https://img.shields.io/hackage/v/jsonschema.svg)](https://hackage.haskell.org/package/jsonschema) + Haskell library for deriving and validating JSON Schema (2020-12). This library provides: @@ -15,7 +17,7 @@ ## Features - Derive schemas with the `ToJSONSchema` type class; generic default handles most ADTs. -- Records become JSON objects with named properties, emit `"required"` for every field, and forbid extras via `additionalProperties: false`. Non-record products become arrays with `prefixItems` and `items: false`. +- Records become JSON objects with named properties, emit `"required"` for every field, and forbid extras via `additionalProperties: false`. Non-record products become fixed-length arrays with `prefixItems`, `items: false`, and `minItems`/`maxItems` pinning the exact length. - Sum types are modeled with discriminator tags: - Record constructors: object with a required `tag` (constructor name) and the record fields. - Non-record constructors: object `{ tag, contents }`, both required, where `contents` carries the constructor’s payload (array/object). @@ -39,8 +41,7 @@ import Data.Aeson (ToJSON, Value, object, (.=)) import Data.Proxy (Proxy(..)) import Data.Text (Text) -import Data.JSON.JSONSchema -- ToJSONSchema(..), Proxy(..), validateJSONSchema -import JSONSchema.Validation -- validate / validateWithErrors (optional) +import Data.JSON.JSONSchema -- ToJSONSchema(..), Proxy(..), validateJSONSchema, validate, validateWithErrors, ValidationError(..) ``` ### 1) Derive a schema for your type @@ -111,7 +112,7 @@ Or collect all validation errors: ```haskell -import JSONSchema.Validation (validate, validateWithErrors, ValidationError(..)) +import Data.JSON.JSONSchema (validate, validateWithErrors, ValidationError(..)) case validate personSchema (toJSON (Person "Alice" 30)) of Right () -> putStrLn "OK" @@ -130,7 +131,42 @@ ``` -### 3) Custom schemas for special types +### 3) Value-directed construction + +When your "types" are runtime *values* rather than Haskell types — e.g. an +interpreter whose type AST is a single datatype — derivation via `ToJSONSchema` +does not apply. Instead, fold your value into a `Schema` and render it; the library +owns the JSON encoding: + +```haskell +import Data.JSON.JSONSchema -- Schema(..), Field(..), AdditionalProperties(..), SchemaDocument(..), schemaToValue, schemaDocumentToValue + +userDoc :: SchemaDocument +userDoc = SchemaDocument + { schemaDefs = [("Code", SString (Just "^[a-z]+$"))] -- a named $def + , schemaRoot = SObject + [ Field "code" True (SRef "Code") -- required, references the $def + , Field "count" False SInteger -- optional + ] + APForbidden -- additionalProperties: false + } + +userSchema :: Value +userSchema = schemaDocumentToValue userDoc + +ok = validateJSONSchema userSchema (object ["code" .= ("abc" :: Text), "count" .= (3 :: Int)]) -- True +bad = validateJSONSchema userSchema (object ["code" .= ("ABC" :: Text)]) -- False (off-pattern) +``` + +A homogeneous map/dictionary is `SObject [] (APSchema valueSchema)` +(`additionalProperties: `). The `pattern` field is matched with TDFA +regexes (POSIX ERE), not the full ECMA-262 dialect, so keep patterns simple. + +`Schema` covers the data-shape subset; for any keyword outside it (e.g. +`minLength`, numeric bounds, `title`), use the `SRaw` escape hatch to embed an +arbitrary schema `Value` at any node — e.g. `Field "name" True (SRaw (object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)]))`. + +### 4) Custom schemas for special types Provide an explicit instance when you need a specific schema shape: diff --git a/jsonschema.cabal b/jsonschema.cabal --- a/jsonschema.cabal +++ b/jsonschema.cabal @@ -1,12 +1,14 @@ -cabal-version: 2.2 -name: jsonschema -version: 0.2.0.1 -license: MPL-2.0 -license-file: LICENSE -author: DPella AB -maintainer: matti@dpella.io, - lobo@dpella.io -synopsis: JSON Schema derivation and validation +cabal-version: 2.2 +name: jsonschema +version: 0.3.0.0 +license: MPL-2.0 +license-file: LICENSE +author: DPella AB +maintainer: + matti@dpella.io, + lobo@dpella.io + +synopsis: JSON Schema derivation and validation description: Provides the `ToJSONSchema` type class and validation helpers for generating JSON Schema 2020-12 documents from Haskell types and validating JSON values at runtime. @@ -14,58 +16,73 @@ sum-tag encoding, and refined handling of arrays and enumerations. Validation implements the core and applicator vocabularies, including `$defs` and local `$ref` resolution, pragmatic support for `unevaluated*` keywords, and detailed error traces. -extra-doc-files: CHANGELOG.md, README.md -homepage: https://github.com/DPella/jsonschema -bug-reports: https://github.com/DPella/jsonschema/issues -category: Data, JSON -tested-with: GHC == 9.6, GHC == 9.12 +extra-doc-files: + CHANGELOG.md + README.md + +homepage: https://github.com/DPella/jsonschema +bug-reports: https://github.com/DPella/jsonschema/issues +category: Data, JSON +tested-with: + ghc ==9.6 + ghc ==9.12 + library default-language: Haskell2010 + default-extensions: - DataKinds - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , ImportQualifiedPost - , LambdaCase - , OverloadedStrings - , PolyKinds - , RankNTypes - , TypeApplications + DataKinds + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + OverloadedStrings + PolyKinds + RankNTypes + TypeApplications + hs-source-dirs: src + exposed-modules: Data.JSON.JSONSchema + other-modules: + Data.JSON.Schema Data.JSON.ToJSONSchema JSONSchema.Validation - build-depends: - base >=4.18 && <4.22 - , text >= 2.0 && <2.2 - , aeson >= 2.2 && <2.3 - , containers >= 0.6.7 && <0.9 - , vector >=0.13 && < 0.14 - , scientific >= 0.3.8 && <0.4 - , regex-tdfa >= 1.3.2 && <1.4 + build-depends: + aeson >=2.2 && <2.3, + base >=4.18 && <4.22, + containers >=0.6.7 && <0.9, + regex-tdfa >=1.3.2 && <1.4, + scientific >=0.3.8 && <0.4, + text >=2.0 && <2.2, + vector >=0.13 && <0.14, test-suite test-jsonschema type: exitcode-stdio-1.0 default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + other-modules: JSONSchema.Spec + build-depends: - base >=4.18 && <4.22 - , jsonschema - , aeson - , text - , vector - , tasty - , tasty-hunit + aeson, + base >=4.18 && <4.22, + jsonschema, + tasty, + tasty-hunit, + text, + vector, diff --git a/src/Data/JSON/JSONSchema.hs b/src/Data/JSON/JSONSchema.hs --- a/src/Data/JSON/JSONSchema.hs +++ b/src/Data/JSON/JSONSchema.hs @@ -1,44 +1,58 @@ --- | --- Module: Data.JSON.JSONSchema --- Copyright: (c) DPella AB 2025 --- License: LicenseRef-AllRightsReserved --- Maintainer: , --- --- JSON Schema generation for Haskell types. --- --- This module provides a type class and generic implementation for --- automatically deriving JSON Schema descriptions from Haskell data types. --- The generated schemas follow the JSON Schema 2020-12 specification. --- --- = Usage --- --- Define instances using the default generic implementation: --- --- @ --- data Person = Person --- { name :: Text --- , age :: Int --- } deriving (Generic) --- --- instance ToJSONSchema Person --- @ --- --- Or provide custom instances for more control: --- --- @ --- instance ToJSONSchema UUID where --- toJSONSchema _ = object --- [ "type" .= ("string" :: Text) --- , "minLength" .= 36 --- , "maxLength" .= 36 --- ] --- @ +{- | +Module: Data.JSON.JSONSchema +Copyright: (c) DPella AB 2025 +License: LicenseRef-AllRightsReserved +Maintainer: , + +JSON Schema generation for Haskell types. + +This module provides a type class and generic implementation for +automatically deriving JSON Schema descriptions from Haskell data types. +The generated schemas follow the JSON Schema 2020-12 specification. + += Usage + +Define instances using the default generic implementation: + +@ +data Person = Person + { name :: Text + , age :: Int + } deriving (Generic) + +instance ToJSONSchema Person +@ + +Or provide custom instances for more control: + +@ +instance ToJSONSchema UUID where + toJSONSchema _ = object + [ "type" .= ("string" :: Text) + , "minLength" .= 36 + , "maxLength" .= 36 + ] +@ +-} module Data.JSON.JSONSchema ( - ToJSONSchema (..), - Proxy (..), - validateJSONSchema, + ToJSONSchema (..), + Proxy (..), + + -- * Validation + validateJSONSchema, + validate, + validateWithErrors, + ValidationError (..), + + -- * Value-directed construction + Schema (..), + Field (..), + AdditionalProperties (..), + SchemaDocument (..), + schemaToValue, + schemaDocumentToValue, ) where -import Data.Proxy +import Data.JSON.Schema import Data.JSON.ToJSONSchema import JSONSchema.Validation diff --git a/src/Data/JSON/Schema.hs b/src/Data/JSON/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Schema.hs @@ -0,0 +1,242 @@ +{- | +Module: Data.JSON.Schema +Copyright: (c) DPella AB 2025 +License: LicenseRef-AllRightsReserved +Maintainer: , + +Value-directed JSON Schema construction. + +A structured, value-level description of the data-shape subset of JSON Schema +2020-12, plus pure renderers to an Aeson 'Value'. This is the value-directed +complement to the type-directed 'Data.JSON.ToJSONSchema.ToJSONSchema': rather than +reflecting on a Haskell /type/, you build a 'Schema' from runtime data (e.g. an +interpreter folding over its own type AST) and let this module own the JSON +encoding. + +The vocabulary is exactly the data-shape subset the generic derivation emits and +the bundled validator accepts (@properties@/@required@/@additionalProperties@, +@prefixItems@/@items@, @anyOf@/@allOf@, @$ref@/@$defs@, @pattern@, @uniqueItems@). +Validation-only keywords (@if@/@then@/@else@, @dependentSchemas@, +@patternProperties@, @not@, …) are intentionally absent: they are for validating +arbitrary schemas, not for generating a data shape. + +This is deliberately narrower than the type-directed path, and that gap is by +design rather than an oversight: 'Schema' is the ergonomic DSL for the common +data-shape case, not a typed mirror of the whole specification. When you need a +keyword outside this subset (e.g. @minLength@, numeric bounds, @title@), embed it +with 'SRaw', which renders an arbitrary schema 'Value' verbatim and composes +anywhere a 'Schema' is expected (an object field, an array element, an @anyOf@ +branch). The bundled validator accepts arbitrary schemas, so the embedded 'Value' +validates like any other. + += Usage + +@ +doc :: t'SchemaDocument' +doc = v'SchemaDocument' + { 'schemaDefs' = [(\"Code\", 'SString' (Just \"^[a-z]+$\"))] + , 'schemaRoot' = + 'SObject' + [ v'Field' \"code\" True ('SRef' \"Code\") + , v'Field' \"count\" False 'SInteger' + ] + 'APForbidden' + } + +schema :: Value +schema = 'schemaDocumentToValue' doc +@ +-} +module Data.JSON.Schema ( + -- * Schema description + Schema (..), + Field (..), + AdditionalProperties (..), + + -- * Documents + SchemaDocument (..), + + -- * Rendering + schemaToValue, + schemaDocumentToValue, +) where + +import Data.Aeson +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Text (Text) +import Data.Text qualified as T + +{- | A value-level description of the data-shape subset of JSON Schema 2020-12 — +the value-directed complement to the type-directed +'Data.JSON.ToJSONSchema.ToJSONSchema'. Build a 'Schema' from runtime data, then +render it with 'schemaToValue'. +-} +data Schema + = -- | @{"type":"null"}@ + SNull + | -- | @{"type":"boolean"}@ + SBoolean + | -- | @{"type":"integer"}@ + SInteger + | -- | @{"type":"number"}@ + SNumber + | -- | @{"type":"string"}@, with a @pattern@ when 'Just'. + SString (Maybe Text) + | -- | @{"const": v}@ + SConst Value + | -- | @{"enum": [..]}@ + SEnum [Value] + | -- | @{"type":"array","items": s}@ + SArray Schema + | -- | Array with @uniqueItems: true@ (a set). + SArrayUnique Schema + | -- | Fixed-length tuple: @prefixItems@ + @items:false@ + @minItems@/@maxItems@. + STuple [Schema] + | {- | Object: each t'Field' carries its own requiredness, plus how additional + properties are treated. + -} + SObject [Field] AdditionalProperties + | -- | @{"anyOf": [s, {"type":"null"}]}@ + SNullable Schema + | -- | @{"anyOf": [..]}@ + SAnyOf [Schema] + | -- | @{"allOf": [..]}@ + SAllOf [Schema] + | -- | @{"$ref": "#/$defs/"}@ (the name is JSON-Pointer-escaped). + SRef Text + | -- | @{}@ (matches anything). + SAny + | {- | Escape hatch: render an arbitrary schema 'Value' verbatim, so a node + outside this subset (e.g. a string with @minLength@, a number with + @multipleOf@) can still be embedded inside an otherwise structured + 'Schema'. Unchecked — the 'Value' is emitted as-is. + -} + SRaw Value + deriving (Eq, Show) + +{- | A single property of an 'SObject'. + +Pairing requiredness with the property's schema makes a "required but undeclared" +property unrepresentable — a contradiction (@required@ together with +@additionalProperties:false@) the validator would otherwise reject. + +Duplicate 'fieldName's within one 'SObject' are caller error: they collapse to a +single JSON property (last wins). +-} +data Field = Field + { fieldName :: Text + -- ^ The property key. + , fieldRequired :: Bool + -- ^ Whether the property must be present. + , fieldSchema :: Schema + -- ^ The schema the property's value must satisfy. + } + deriving (Eq, Show) + +-- | How an 'SObject' treats properties not declared in its t'Field's. +data AdditionalProperties + = -- | @{"additionalProperties": false}@ + APForbidden + | -- | @{"additionalProperties": true}@ + APAllowed + | -- | @{"additionalProperties": s}@ — homogeneous maps/dictionaries. + APSchema Schema + deriving (Eq, Show) + +{- | A self-contained schema document: a root schema plus local @$defs@ for named +subschemas (so every 'SRef' resolves within the document), tagged with the 2020-12 +dialect. +-} +data SchemaDocument = SchemaDocument + { schemaDefs :: [(Text, Schema)] + -- ^ Named subschemas, exposed under @$defs@ for 'SRef' to resolve against. + , schemaRoot :: Schema + -- ^ The document's root schema. + } + deriving (Eq, Show) + +-- | Render a 'Schema' to its Aeson 'Value'. A total, pure fold. +schemaToValue :: Schema -> Value +schemaToValue = \case + SNull -> typed "null" + SBoolean -> typed "boolean" + SInteger -> typed "integer" + SNumber -> typed "number" + SString Nothing -> typed "string" + SString (Just p) -> object ["type" .= ("string" :: Text), "pattern" .= p] + SConst v -> object ["const" .= v] + SEnum vs -> object ["enum" .= vs] + SArray s -> object ["type" .= ("array" :: Text), "items" .= schemaToValue s] + SArrayUnique s -> + object + [ "type" .= ("array" :: Text) + , "items" .= schemaToValue s + , "uniqueItems" .= True + ] + STuple ss -> + object + [ "type" .= ("array" :: Text) + , "prefixItems" .= map schemaToValue ss + , "items" .= False + , "minItems" .= length ss + , "maxItems" .= length ss + ] + SObject fields ap -> objectToValue fields ap + SNullable s -> object ["anyOf" .= [schemaToValue s, typed "null"]] + SAnyOf ss -> object ["anyOf" .= map schemaToValue ss] + SAllOf ss -> object ["allOf" .= map schemaToValue ss] + SRef name -> object ["$ref" .= ("#/$defs/" <> escapePointer name)] + SAny -> object [] + SRaw v -> v + where + typed t = object ["type" .= (t :: Text)] + +-- | Render an 'SObject', omitting @required@ when no field is required. +objectToValue :: [Field] -> AdditionalProperties -> Value +objectToValue fields ap = + object $ + [ "type" .= ("object" :: Text) + , "properties" .= object [K.fromText (fieldName f) .= schemaToValue (fieldSchema f) | f <- fields] + , "additionalProperties" .= additionalPropertiesToValue ap + ] + ++ requiredPairs + where + requiredNames = [fieldName f | f <- fields, fieldRequired f] + requiredPairs + | null requiredNames = [] + | otherwise = ["required" .= requiredNames] + +-- | Render the @additionalProperties@ value. +additionalPropertiesToValue :: AdditionalProperties -> Value +additionalPropertiesToValue = \case + APForbidden -> Bool False + APAllowed -> Bool True + APSchema s -> schemaToValue s + +{- | Escape a name for use as a JSON Pointer token (RFC 6901): @~@ becomes @~0@, +then @/@ becomes @~1@. Order matters — escaping @~@ first keeps a literal @/@ from +producing a spurious @~01@. +-} +escapePointer :: Text -> Text +escapePointer = T.replace "/" "~1" . T.replace "~" "~0" + +{- | Render a t'SchemaDocument' to its Aeson 'Value': the root schema inline, with +a @$schema@ dialect header and (when non-empty) a sibling @$defs@ block. + +The document owns @$schema@/@$defs@: should the root be an 'SRaw' object that also +carries those keys, the document's win. A non-object root — only reachable via +'SRaw' (e.g. a boolean schema) — is wrapped under @allOf@ so the header is still +emitted rather than silently dropped. +-} +schemaDocumentToValue :: SchemaDocument -> Value +schemaDocumentToValue (SchemaDocument defs root) = + case schemaToValue root of + Object rootObj -> Object (header `KM.union` rootObj) + other -> Object (KM.insert "allOf" (toJSON [other]) header) + where + header = KM.fromList (("$schema", String dialect) : defsPair) + dialect = "https://json-schema.org/draft/2020-12/schema" + defsPair + | null defs = [] + | otherwise = [("$defs", object [K.fromText n .= schemaToValue s | (n, s) <- defs])] diff --git a/src/Data/JSON/ToJSONSchema.hs b/src/Data/JSON/ToJSONSchema.hs --- a/src/Data/JSON/ToJSONSchema.hs +++ b/src/Data/JSON/ToJSONSchema.hs @@ -4,44 +4,45 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} --- | --- Module: Data.JSON.ToJSONSchema --- Copyright: (c) DPella AB 2025 --- License: LicenseRef-AllRightsReserved --- Maintainer: , --- --- Core machinery for deriving JSON Schema definitions from Haskell types. --- --- This module provides a type class and generic implementation for --- automatically deriving JSON Schema descriptions from Haskell data types. --- The generated schemas follow the JSON Schema 2020-12 specification. --- --- = Usage --- --- Define instances using the default generic implementation: --- --- @ --- data Person = Person --- { name :: Text --- , age :: Int --- } deriving (Generic) --- --- instance ToJSONSchema Person --- @ --- --- Or provide custom instances for more control: --- --- @ --- instance ToJSONSchema UUID where --- toJSONSchema _ = object --- [ "type" .= ("string" :: Text) --- , "minLength" .= 36 --- , "maxLength" .= 36 --- ] --- @ +{- | +Module: Data.JSON.ToJSONSchema +Copyright: (c) DPella AB 2025 +License: LicenseRef-AllRightsReserved +Maintainer: , + +Core machinery for deriving JSON Schema definitions from Haskell types. + +This module provides a type class and generic implementation for +automatically deriving JSON Schema descriptions from Haskell data types. +The generated schemas follow the JSON Schema 2020-12 specification. + += Usage + +Define instances using the default generic implementation: + +@ +data Person = Person + { name :: Text + , age :: Int + } deriving (Generic) + +instance ToJSONSchema Person +@ + +Or provide custom instances for more control: + +@ +instance ToJSONSchema UUID where + toJSONSchema _ = object + [ "type" .= ("string" :: Text) + , "minLength" .= 36 + , "maxLength" .= 36 + ] +@ +-} module Data.JSON.ToJSONSchema ( - ToJSONSchema (..), - Proxy (..), + ToJSONSchema (..), + Proxy (..), ) where import Data.Aeson @@ -56,397 +57,425 @@ import GHC.Generics import GHC.TypeLits --- | Type class for converting Haskell types to JSON Schema. --- --- The class provides a default implementation using GHC generics, --- which works for most algebraic data types. Custom instances can --- be defined for types requiring special schema representations. +{- | Type class for converting Haskell types to JSON Schema. + +The class provides a default implementation using GHC generics, +which works for most algebraic data types. Custom instances can +be defined for types requiring special schema representations. +-} class ToJSONSchema a where - -- | Generate a JSON Schema for the given type. - -- - -- The Proxy argument carries the type information without - -- requiring an actual value of that type. - -- - -- >>> toJSONSchema (Proxy :: Proxy Bool) - -- {"type": "boolean"} - toJSONSchema :: Proxy a -> Value - default toJSONSchema - :: ( Generic a - , GToJSONSchema (Rep a) - , Typeable a - ) - => Proxy a - -> Value - -- We start with no root name; the D1 instance will set the root name - -- and wrap the result with $defs and a top-level $ref. This allows - -- recursive types to refer to themselves using $ref without infinite recursion. - toJSONSchema _ = gToJSONSchema @(Rep a) False Nothing (Proxy :: Proxy (Rep a a)) + {- | Generate a JSON Schema for the given type. + The Proxy argument carries the type information without + requiring an actual value of that type. + + >>> toJSONSchema (Proxy :: Proxy Bool) + {"type": "boolean"} + -} + toJSONSchema :: Proxy a -> Value + default toJSONSchema :: + ( Generic a + , GToJSONSchema (Rep a) + , Typeable a + ) => + Proxy a -> + Value + -- We start with no root name; the D1 instance will set the root name + -- and wrap the result with $defs and a top-level $ref. This allows + -- recursive types to refer to themselves using $ref without infinite recursion. + toJSONSchema _ = gToJSONSchema @(Rep a) False Nothing (Proxy :: Proxy (Rep a a)) + -- | String instance with overlapping to handle String as a special case, and not as [Char] instance {-# OVERLAPPING #-} ToJSONSchema String where - toJSONSchema _ = object ["type" .= ("string" :: Text)] + toJSONSchema _ = object ["type" .= ("string" :: Text)] -- | Text instance. instance ToJSONSchema Text where - toJSONSchema _ = object ["type" .= ("string" :: Text)] + toJSONSchema _ = object ["type" .= ("string" :: Text)] -- | Boolean schema instance. instance ToJSONSchema Bool where - toJSONSchema _ = object ["type" .= ("boolean" :: Text)] + toJSONSchema _ = object ["type" .= ("boolean" :: Text)] -- | Machine integer schema instance. instance ToJSONSchema Int where - toJSONSchema _ = object ["type" .= ("integer" :: Text)] + toJSONSchema _ = object ["type" .= ("integer" :: Text)] -- | Arbitrary precision integer schema instance. instance ToJSONSchema Integer where - toJSONSchema _ = object ["type" .= ("integer" :: Text)] + toJSONSchema _ = object ["type" .= ("integer" :: Text)] -- | Single precision floating point schema instance. instance ToJSONSchema Float where - toJSONSchema _ = object ["type" .= ("number" :: Text)] + toJSONSchema _ = object ["type" .= ("number" :: Text)] -- | Double precision floating point schema instance. instance ToJSONSchema Double where - toJSONSchema _ = object ["type" .= ("number" :: Text)] + toJSONSchema _ = object ["type" .= ("number" :: Text)] -- | List schema instance for homogeneous arrays. instance (ToJSONSchema a) => ToJSONSchema [a] where - toJSONSchema _ = - object - [ "type" .= ("array" :: Text) - , "items" .= toJSONSchema (Proxy :: Proxy a) - ] + toJSONSchema _ = + object + [ "type" .= ("array" :: Text) + , "items" .= toJSONSchema (Proxy :: Proxy a) + ] --- | Either schema instance for tagged unions. --- --- Encodes as Aeson's default representation with Left/Right tags: --- @ --- Left x -> {\"Left\": x} --- Right y -> {\"Right\": y} --- @ +{- | Either schema instance for tagged unions. + +Encodes as Aeson's default representation with Left/Right tags: +@ +Left x -> {\"Left\": x} +Right y -> {\"Right\": y} +@ +-} instance (ToJSONSchema a, ToJSONSchema b) => ToJSONSchema (Either a b) where - toJSONSchema _ = - object - [ "anyOf" - .= [ object - [ "type" .= ("object" :: Text) - , "properties" - .= object - [ "Left" .= toJSONSchema (Proxy :: Proxy a) - ] - , "required" .= ([ "Left" ] :: [Text]) - , "additionalProperties" .= False - ] - , object - [ "type" .= ("object" :: Text) - , "properties" - .= object - [ "Right" .= toJSONSchema (Proxy :: Proxy b) - ] - , "required" .= ([ "Right" ] :: [Text]) - , "additionalProperties" .= False - ] - ] - ] + toJSONSchema _ = + object + [ "anyOf" + .= [ object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "Left" .= toJSONSchema (Proxy :: Proxy a) + ] + , "required" .= (["Left"] :: [Text]) + , "additionalProperties" .= False + ] + , object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "Right" .= toJSONSchema (Proxy :: Proxy b) + ] + , "required" .= (["Right"] :: [Text]) + , "additionalProperties" .= False + ] + ] + ] --- | Maybe schema instance allowing null values. --- --- A Maybe value can be either the wrapped type or null: --- @ --- Just x -> x --- Nothing -> null --- @ +{- | Maybe schema instance allowing null values. + +A Maybe value can be either the wrapped type or null: +@ +Just x -> x +Nothing -> null +@ +-} instance (ToJSONSchema a) => ToJSONSchema (Maybe a) where - toJSONSchema _ = - object - [ "anyOf" - .= [ toJSONSchema (Proxy :: Proxy a) - , object ["type" .= ("null" :: Text)] - ] - ] + toJSONSchema _ = + object + [ "anyOf" + .= [ toJSONSchema (Proxy :: Proxy a) + , object ["type" .= ("null" :: Text)] + ] + ] --- | Generic type class for deriving JSON schemas. --- --- This class handles the generic representation of data types --- and converts them to appropriate JSON Schema structures. --- --- The Bool parameter indicates whether we're inside a sum type --- that needs tagging for proper deserialization. +{- | Generic type class for deriving JSON schemas. + +This class handles the generic representation of data types +and converts them to appropriate JSON Schema structures. + +The Bool parameter indicates whether we're inside a sum type +that needs tagging for proper deserialization. +-} class GToJSONSchema f where - -- | Generate schema from generic representation. - -- - -- The Bool parameter controls tagged union representation: - -- * True: Add "tag" field for sum type constructors - -- * False: No tagging needed - -- The Maybe Text carries the root datatype name, if any. When present, - -- occurrences of the same datatype in fields will be rendered as - -- {"$ref": "#/$defs/"} to avoid infinite recursion. - gToJSONSchema :: (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (f a) -> Value + {- | Generate schema from generic representation. --- | Instance for empty types (no constructors). --- --- Empty types are represented as JSON null since they --- can never have a value. + The Bool parameter controls tagged union representation: + * True: Add "tag" field for sum type constructors + * False: No tagging needed + The Maybe Text carries the root datatype name, if any. When present, + occurrences of the same datatype in fields will be rendered as + {"$ref": "#/$defs/"} to avoid infinite recursion. + -} + gToJSONSchema :: (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (f a) -> Value + +{- | Instance for empty types (no constructors). + +Empty types are represented as JSON null since they +can never have a value. +-} instance GToJSONSchema V1 where - gToJSONSchema _ _ _ = Null + gToJSONSchema _ _ _ = Null --- | Instance for unit types (constructors with no fields). --- --- Unit constructors are represented as null when untagged, --- or as objects with just a tag field when tagged. +{- | Instance for unit types (constructors with no fields). + +Unit constructors are represented as null when untagged, +or as objects with just a tag field when tagged. +-} instance GToJSONSchema U1 where - gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (U1 a) -> Value - gToJSONSchema _ _ _ = Null + gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (U1 a) -> Value + gToJSONSchema _ _ _ = Null --- | Instance for sum types (multiple constructors). --- --- Sum types are encoded using JSON Schema's "anyOf" keyword, --- allowing the value to match any of the constructor schemas. --- --- Example: --- @ --- data Color = Red | Green | Blue --- -- Generates: {"anyOf": [{...Red schema}, {...Green schema}, {...Blue schema}]} --- @ +{- | Instance for sum types (multiple constructors). + +Sum types are encoded using JSON Schema's "anyOf" keyword, +allowing the value to match any of the constructor schemas. + +Example: +@ +data Color = Red | Green | Blue +-- Generates: {"anyOf": [{...Red schema}, {...Green schema}, {...Blue schema}]} +@ +-} instance (GToJSONSchema f1, GToJSONSchema f2) => GToJSONSchema (f1 :+: f2) where - gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:+:) f1 f2 a) -> Value - gToJSONSchema _ root_name _ = - let v1 = flattenKeys "anyOf" $ gToJSONSchema True root_name (Proxy :: Proxy (f1 a)) - v2 = flattenKeys "anyOf" $ gToJSONSchema True root_name (Proxy :: Proxy (f2 a)) - in case (v1, v2) of - (Object km1, Object km2) - | Just (Array vec1) <- km1 KM.!? "anyOf" - , Just (Array vec2) <- km2 KM.!? "anyOf" -> - object ["anyOf" .= Array (vec1 <> vec2)] - (Object km1, Object km2) - | Just (Array vec) <- km1 KM.!? "anyOf" - , Nothing <- km2 KM.!? "anyOf" -> - object ["anyOf" .= Array (vec `V.snoc` v2)] - (Object _, Object km2) - | Just (Array vec) <- km2 KM.!? "anyOf" -> - object ["anyOf" .= Array (v1 `V.cons` vec)] - (_, _) -> object ["anyOf" .= [v1, v2]] + gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:+:) f1 f2 a) -> Value + gToJSONSchema _ root_name _ = + let v1 = flattenKeys "anyOf" $ gToJSONSchema True root_name (Proxy :: Proxy (f1 a)) + v2 = flattenKeys "anyOf" $ gToJSONSchema True root_name (Proxy :: Proxy (f2 a)) + in case (v1, v2) of + (Object km1, Object km2) + | Just (Array vec1) <- km1 KM.!? "anyOf" + , Just (Array vec2) <- km2 KM.!? "anyOf" -> + object ["anyOf" .= Array (vec1 <> vec2)] + (Object km1, Object km2) + | Just (Array vec) <- km1 KM.!? "anyOf" + , Nothing <- km2 KM.!? "anyOf" -> + object ["anyOf" .= Array (vec `V.snoc` v2)] + (Object _, Object km2) + | Just (Array vec) <- km2 KM.!? "anyOf" -> + object ["anyOf" .= Array (v1 `V.cons` vec)] + (_, _) -> object ["anyOf" .= [v1, v2]] --- | Instance for product types (multiple fields in a constructor). --- --- Non-record products are encoded as fixed-length arrays where --- each position has a specific type. The "items": false ensures --- no additional array elements are allowed. --- --- Example: --- @ --- data Point = Point Double Double --- -- Generates: {"type": "array", "prefixItems": [{"type": "number"}, {"type": "number"}], "items": false} --- @ +{- | Instance for product types (multiple fields in a constructor). + +Non-record products are encoded as fixed-length arrays where each position has a +specific type, via "prefixItems" + "items": false. (The enclosing non-record +/constructor/ instance additionally pins the exact length with +"minItems"/"maxItems".) + +Example: +@ +data Point = Point Double Double +-- This instance emits: {"type": "array", "prefixItems": [{"type": "number"}, {"type": "number"}], "items": false} +@ +-} instance (GToJSONSchema f1, GToJSONSchema f2) => GToJSONSchema (f1 :*: f2) where - gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:*:) f1 f2 a) -> Value - gToJSONSchema _ root_name _ = - object - [ "type" .= ("array" :: Text) - , "prefixItems" - .= [ gToJSONSchema False root_name (Proxy :: Proxy (f1 a)) - , gToJSONSchema False root_name (Proxy :: Proxy (f2 a)) - ] - , "items" .= False - ] + gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:*:) f1 f2 a) -> Value + gToJSONSchema _ root_name _ = + object + [ "type" .= ("array" :: Text) + , "prefixItems" + .= [ gToJSONSchema False root_name (Proxy :: Proxy (f1 a)) + , gToJSONSchema False root_name (Proxy :: Proxy (f2 a)) + ] + , "items" .= False + ] --- | Helper to flatten nested array structures in schemas. --- --- When building schemas for nested product types, we may get --- structures like prefixItems: [a, {prefixItems: [b, c]}]. --- This function flattens them to prefixItems: [a, b, c] for --- consistency with how Aeson represents such types. +{- | Helper to flatten nested array structures in schemas. + +When building schemas for nested product types, we may get +structures like prefixItems: [a, {prefixItems: [b, c]}]. +This function flattens them to prefixItems: [a, b, c] for +consistency with how Aeson represents such types. +-} flattenKeys :: Key -> Value -> Value flattenKeys key (Object km) - | Just (Array vec) <- km KM.!? key - , length vec == 2 - , vf <- V.head vec - , Object vlkm <- flattenKeys key (V.last vec) - , Just (Array vec') <- vlkm KM.!? key = - Object - ( KM.singleton - key - (Array (V.cons vf vec')) - `KM.union` km - ) + | Just (Array vec) <- km KM.!? key + , length vec == 2 + , vf <- V.head vec + , Object vlkm <- flattenKeys key (V.last vec) + , Just (Array vec') <- vlkm KM.!? key = + Object + ( KM.singleton + key + (Array (V.cons vf vec')) + `KM.union` km + ) flattenKeys _ o = o --- | Instance for datatype metadata. --- If this is the root, we output a $defs section with the type name and schema, --- and refer to that in $ref. +{- | Instance for datatype metadata. +If this is the root, we output a $defs section with the type name and schema, +and refer to that in $ref. +-} instance (KnownSymbol dtn, GToJSONSchema f) => GToJSONSchema (D1 (MetaData dtn m p nt) f) where - gToJSONSchema - :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (D1 (MetaData dtn m p nt) f a) -> Value - gToJSONSchema _ root_name _ = - let dt_name = symbolVal (Proxy :: Proxy dtn) - this_name = pack dt_name - body = gToJSONSchema False (Just this_name) (Proxy :: Proxy (f a)) - in case root_name of - -- Top-level: wrap with $defs and $ref to support recursion - Nothing -> - object - [ "$defs" .= object [fromString dt_name .= body] - , "$ref" .= ("#/$defs/" <> this_name) - ] - -- Nested: just return the documented body - Just _ -> body + gToJSONSchema :: + forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (D1 (MetaData dtn m p nt) f a) -> Value + gToJSONSchema _ root_name _ = + let dt_name = symbolVal (Proxy :: Proxy dtn) + this_name = pack dt_name + body = gToJSONSchema False (Just this_name) (Proxy :: Proxy (f a)) + in case root_name of + -- Top-level: wrap with $defs and $ref to support recursion + Nothing -> + object + [ "$defs" .= object [fromString dt_name .= body] + , "$ref" .= ("#/$defs/" <> this_name) + ] + -- Nested: just return the documented body + Just _ -> body --- | Instance for type constants (actual field types). --- --- This delegates to the ToJSONSchema instance of the field type, --- allowing custom schemas for specific types. +{- | Instance for type constants (actual field types). + +This delegates to the ToJSONSchema instance of the field type, +allowing custom schemas for specific types. +-} instance (ToJSONSchema c, Typeable c) => GToJSONSchema (K1 i c) where - gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (K1 i c a) -> Value - gToJSONSchema _ root_name _ = - case root_name of - -- If we know the root type name and the field type equals the root - -- type, emit a $ref to the root definition to avoid infinite recursion. - Just nm -> - if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy c) - then object ["$ref" .= ("#/$defs/" <> nm)] - else toJSONSchema (Proxy :: Proxy c) - Nothing -> toJSONSchema (Proxy :: Proxy c) + gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (K1 i c a) -> Value + gToJSONSchema _ root_name _ = + case root_name of + -- If we know the root type name and the field type equals the root + -- type, emit a $ref to the root definition to avoid infinite recursion. + Just nm -> + if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy c) + then object ["$ref" .= ("#/$defs/" <> nm)] + else toJSONSchema (Proxy :: Proxy c) + Nothing -> toJSONSchema (Proxy :: Proxy c) --- | Instance for record constructors. --- --- Record types are encoded as objects with named properties. --- When in a tagged sum type, adds a "tag" field with the --- constructor name for discrimination. --- --- Example: --- @ --- data Person = Person {name :: Text, age :: Int} --- -- Generates: { --- -- "type": "object", --- -- "properties": { --- -- "name": {"type": "string"}, --- -- "age": {"type": "integer"} --- -- }, --- -- "additionalProperties": false --- -- } --- @ -instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity True) f) where - gToJSONSchema - :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity True) f a) -> Value - gToJSONSchema tagged root_name _ = - let props_val = extractProperties $ gToJSONSchema tagged root_name (Proxy :: Proxy (f a)) - props_keys = - case props_val of - Object km -> fmap K.toText (KM.keys km) - _ -> [] - requiredFields = - (if tagged then ("tag" :) else id) props_keys - requiredPairs = - if null requiredFields - then [] - else ["required" .= requiredFields] - in object - ( [ "type" .= ("object" :: Text) - , "properties" .= if tagged then addTag props_val else props_val - , "additionalProperties" .= False - ] - ++ requiredPairs - ) - where - tag = object ["const" .= cn] - addTag (Object km) = Object $ KM.singleton (fromString "tag") tag `KM.union` km - addTag o = o - xP (Object p) | Just (Object r) <- p KM.!? "properties" = Just r - xP _ = Nothing - cn = symbolVal (Proxy :: Proxy name) - extractProperties :: Value -> Value - extractProperties o@(Object _) - | Object km <- flattenKeys "prefixItems" o - , Just (Array vec) <- km KM.!? "prefixItems" - , V.all (isJust . xP) vec = - Object $ V.foldl KM.union KM.empty $ V.mapMaybe xP vec - extractProperties (Object km) | Just p <- km KM.!? "properties" = p - extractProperties o = o +{- | Instance for record constructors. --- | Instance for non-record constructors. --- --- Non-record constructors with multiple fields are encoded as arrays. --- When in a tagged sum type, wraps in an object with "tag" and "contents". --- --- Examples: --- @ --- data Point = Point Double Double --- -- Untagged: {"type": "array", "prefixItems": [...], "items": false} --- --- data Shape = Circle Double | Rectangle Double Double --- -- Tagged: { --- -- "type": "object", --- -- "properties": { --- -- "tag": {"const": "Circle"}, --- -- "contents": {"type": "number"} --- -- } --- -- } --- @ -instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity False) f) where - gToJSONSchema - :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity False) f a) -> Value - gToJSONSchema tagged root_name _ = - let c_val = flattenKeys "prefixItems" $ gToJSONSchema False root_name (Proxy :: Proxy (f a)) - c_name = symbolVal (Proxy :: Proxy name) - tag = object ["const" .= c_name] - in case c_val of - o@(Object km) -> - let obj = case km KM.!? "prefixItems" of - Just pfi@(Array _) -> object ["type" .= ("array" :: Text), "prefixItems" .= pfi, "items" .= False] - _ -> o - basePairs = - [ "type" .= ("object" :: Text) - , "properties" .= object ["tag" .= tag, "contents" .= obj] +Record types are encoded as objects with named properties. +When in a tagged sum type, adds a "tag" field with the +constructor name for discrimination. + +Example: +@ +data Person = Person {name :: Text, age :: Int} +-- Generates: { +-- "type": "object", +-- "properties": { +-- "name": {"type": "string"}, +-- "age": {"type": "integer"} +-- }, +-- "additionalProperties": false +-- } +@ +-} +instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity True) f) where + gToJSONSchema :: + forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity True) f a) -> Value + gToJSONSchema tagged root_name _ = + let props_val = extractProperties $ gToJSONSchema tagged root_name (Proxy :: Proxy (f a)) + props_keys = + case props_val of + Object km -> fmap K.toText (KM.keys km) + _ -> [] + requiredFields = + (if tagged then ("tag" :) else id) props_keys + requiredPairs = + if null requiredFields + then [] + else ["required" .= requiredFields] + in object + ( [ "type" .= ("object" :: Text) + , "properties" .= if tagged then addTag props_val else props_val , "additionalProperties" .= False ] - requiredPairs = - ["required" .= (["tag", "contents"] :: [Text])] - in if tagged - then - object (basePairs ++ requiredPairs) - else obj - Null -> - object - [ "type" .= ("object" :: Text) - , "properties" .= object ["tag" .= tag] - , "additionalProperties" .= False - , "required" .= ([ "tag" ] :: [Text]) - ] - x -> x + ++ requiredPairs + ) + where + tag = object ["const" .= cn] + addTag (Object km) = Object $ KM.singleton (fromString "tag") tag `KM.union` km + addTag o = o + xP (Object p) | Just (Object r) <- p KM.!? "properties" = Just r + xP _ = Nothing + cn = symbolVal (Proxy :: Proxy name) + extractProperties :: Value -> Value + extractProperties o@(Object _) + | Object km <- flattenKeys "prefixItems" o + , Just (Array vec) <- km KM.!? "prefixItems" + , V.all (isJust . xP) vec = + Object $ V.foldl KM.union KM.empty $ V.mapMaybe xP vec + extractProperties (Object km) | Just p <- km KM.!? "properties" = p + extractProperties o = o --- | Instance for unnamed fields (positional constructor arguments). --- --- Simply delegates to the field type's schema without wrapping. +{- | Instance for non-record constructors. + +Non-record constructors with multiple fields are encoded as arrays. +When in a tagged sum type, wraps in an object with "tag" and "contents". + +Examples: +@ +data Point = Point Double Double +-- Untagged: {"type": "array", "prefixItems": [...], "items": false, "minItems": 2, "maxItems": 2} + +data Shape = Circle Double | Rectangle Double Double +-- Tagged: { +-- "type": "object", +-- "properties": { +-- "tag": {"const": "Circle"}, +-- "contents": {"type": "number"} +-- } +-- } +@ +-} +instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity False) f) where + gToJSONSchema :: + forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity False) f a) -> Value + gToJSONSchema tagged root_name _ = + let c_val = flattenKeys "prefixItems" $ gToJSONSchema False root_name (Proxy :: Proxy (f a)) + c_name = symbolVal (Proxy :: Proxy name) + tag = object ["const" .= c_name] + in case c_val of + o@(Object km) -> + let obj = case km KM.!? "prefixItems" of + -- A non-record product is a fixed-length tuple: pin the + -- length with minItems/maxItems so a short array is + -- rejected ("items": false only caps the upper end). + Just pfi@(Array vec) -> + object + [ "type" .= ("array" :: Text) + , "prefixItems" .= pfi + , "items" .= False + , "minItems" .= V.length vec + , "maxItems" .= V.length vec + ] + _ -> o + basePairs = + [ "type" .= ("object" :: Text) + , "properties" .= object ["tag" .= tag, "contents" .= obj] + , "additionalProperties" .= False + ] + requiredPairs = + ["required" .= (["tag", "contents"] :: [Text])] + in if tagged + then + object (basePairs ++ requiredPairs) + else obj + Null -> + object + [ "type" .= ("object" :: Text) + , "properties" .= object ["tag" .= tag] + , "additionalProperties" .= False + , "required" .= (["tag"] :: [Text]) + ] + x -> x + +{- | Instance for unnamed fields (positional constructor arguments). + +Simply delegates to the field type's schema without wrapping. +-} instance (GToJSONSchema f) => GToJSONSchema (S1 (MetaSel Nothing su ss ds) f) where - gToJSONSchema - :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel Nothing su ss ds) f a) -> Value - gToJSONSchema _ root_name _ = gToJSONSchema False root_name (Proxy :: Proxy (f a)) + gToJSONSchema :: + forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel Nothing su ss ds) f a) -> Value + gToJSONSchema _ root_name _ = gToJSONSchema False root_name (Proxy :: Proxy (f a)) --- | Instance for named record fields. --- --- Creates an object schema with a single property named after --- the field. These are combined by the record constructor instance. --- --- Example: --- @ --- data Person = Person { name :: Text } --- -- For the 'name' field generates: --- -- { --- -- "type": "object", --- -- "properties": { --- -- "name": {"type": "string"} --- -- } --- -- } --- @ +{- | Instance for named record fields. + +Creates an object schema with a single property named after +the field. These are combined by the record constructor instance. + +Example: +@ +data Person = Person { name :: Text } +-- For the @name@ field generates: +-- { +-- "type": "object", +-- "properties": { +-- "name": {"type": "string"} +-- } +-- } +@ +-} instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (S1 (MetaSel (Just name) su ss ds) f) where - gToJSONSchema - :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel (Just name) su ss ds) f a) -> Value - gToJSONSchema _ root_name _ = - object - [ "type" .= ("object" :: Text) - , "properties" - .= object - [ fromString (symbolVal (Proxy :: Proxy name)) .= gToJSONSchema False root_name (Proxy :: Proxy (f a)) + gToJSONSchema :: + forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel (Just name) su ss ds) f a) -> Value + gToJSONSchema _ root_name _ = + object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ fromString (symbolVal (Proxy :: Proxy name)) .= gToJSONSchema False root_name (Proxy :: Proxy (f a)) + ] ] - ] diff --git a/src/JSONSchema/Validation.hs b/src/JSONSchema/Validation.hs --- a/src/JSONSchema/Validation.hs +++ b/src/JSONSchema/Validation.hs @@ -3,789 +3,806 @@ {-# HLINT ignore "Use ++" #-} --- | --- Module: JSONSchema.Validation --- Copyright: (c) DPella AB 2025 --- License: LicenseRef-AllRightsReserved --- Maintainer: , --- --- JSON Schema validation according to JSON Schema 2020-12. --- --- This module provides validation functions that check if a JSON value --- conforms to a given JSON Schema. It supports the core 2020-12 --- semantics for validation and applicator keywords ("type", "properties", "patternProperties", --- "additionalProperties", "items", "prefixItems", numeric and string --- constraints, combinators, and conditionals). Local $ref resolution to JSON Pointers --- within the same schema document (including paths under "$defs") is supported. --- The "unevaluatedProperties" and "unevaluatedItems" keywords are implemented --- with pragmatic semantics at the current instance location (covering properties/items --- handled by properties/patternProperties/prefixItems/items/contains). The full --- annotation-merging behavior across nested applicators is not implemented. --- The Format-Assertion vocabulary is not implemented; the "format" and "content*" --- keywords are treated as annotations only, per the 2020-12 specification. --- --- = Usage --- --- @ --- let schema = toJSONSchema (Proxy :: Proxy Person) --- let value = object ["name" .= "Alice", "age" .= 30] --- validateJSONSchema schema value -- Returns True if valid --- @ -module JSONSchema.Validation ( - validateJSONSchema, - ValidationError (..), - validate, - validateWithErrors, -) where - -import Data.Aeson -import Data.Aeson.Key qualified as K -import Data.Aeson.KeyMap qualified as KM -import Data.Char (isDigit) -import Data.List (nub) -import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Ratio (denominator) -import Data.Scientific (Scientific) -import Data.Scientific qualified as Sci -import Data.Text (Text) -import Data.Text qualified as T -import Data.Vector qualified as V -import Text.Regex.TDFA ((=~)) -import Text.Regex.TDFA.Text () - --- | Validation error with context about what failed -data ValidationError = ValidationError - { error_path :: [Text] - -- ^ Path to the failing value (e.g. ["users", "0", "name"]) - , error_message :: Text - -- ^ Description of the validation failure - } - deriving (Show, Eq) - --- | Simple validation that returns True if the value matches the schema -validateJSONSchema :: Value -> Value -> Bool -validateJSONSchema schema value = null $ validateWithErrors schema value - --- | Validate with error collection -validate :: Value -> Value -> Either [ValidationError] () -validate schema value = - case validateWithErrors schema value of - [] -> Right () - errs -> Left errs - --- | Validate and return all errors found for an instance against a schema. --- This walks the instance and applies the validation vocabulary for 2020-12, --- returning every violation discovered (no short-circuit). -validateWithErrors :: Value -> Value -> [ValidationError] -validateWithErrors schema value = validateValue [] schema schema value maxRefDepth - --- | Max recursion depth for $ref to avoid infinite loops -maxRefDepth :: Int -maxRefDepth = 256 - --- | Internal validator with context. --- --- Parameters: --- - path: JSON Pointer-like path to the current instance location --- - root: the root schema document (for resolving local $ref) --- - schema: the current subschema to apply --- - value: the current instance value --- - fuel: remaining recursion depth for $ref resolution -validateValue :: [Text] -> Value -> Value -> Value -> Int -> [ValidationError] -validateValue path root schema value fuel = - case schema of - Bool True -> [] -- true schema always validates - Bool False -> [ValidationError path "Schema is false (always fails)"] - Object km -> - -- \$ref short-circuit: if present, ignore other keywords (per spec) - case km KM.!? "$ref" of - Just (String ref_path) -> - if fuel <= 0 - then [ValidationError path "Exceeded $ref resolution depth"] - else case resolveRef root ref_path of - Just ref_schema -> validateValue path root ref_schema value (fuel - 1) - Nothing -> [ValidationError path ("Unresolved $ref: " <> ref_path)] - _ -> validateObject path root km value fuel - _ -> [ValidationError path "Invalid schema: must be a boolean or object"] - --- | Apply object schema keywords and dispatch to other validators. --- --- Covers: --- - type/const/enum --- - Object keywords: properties, patternProperties, additionalProperties, --- propertyNames, required, dependentSchemas, dependentRequired --- - Array keywords present at this location: prefixItems, items (when instance is array) --- - String/Number/Object count constraints --- - Combinators: anyOf, oneOf, allOf, not --- - Conditionals: if/then/else --- - unevaluatedProperties / unevaluatedItems (local, pragmatic semantics) -validateObject :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateObject path root km value fuel = - concat - [ validateType path km value - , validateConst path km value - , validateEnum path km value - , validateProperties path root km value fuel - , validateItems path root km value fuel - , validatePrefixItems path root km value fuel - , validateArrayConstraints path root km value fuel - , validateStringConstraints path km value - , validateNumberConstraints path km value - , validateObjectConstraints path km value - , validateCombinators path root km value fuel - , validateConditional path root km value fuel - , validateUnevaluatedProperties path root km value fuel - , validateUnevaluatedItems path root km value fuel - ] - --- | Validate the "type" keyword. Supports a single string or an array of types. --- Recognized types: null, boolean, string, number, integer, array, object. -validateType :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] -validateType path km value = - case km KM.!? "type" of - Nothing -> [] - Just (String type_str) -> - [ ValidationError path $ "Expected type " <> type_str <> " but got " <> describeType value - | not (checkType type_str value) - ] - Just (Array types) -> - let type_strs = [t | String t <- V.toList types] - in [ ValidationError path $ "Expected one of types " <> T.intercalate ", " type_strs <> " but got " <> describeType value - | not (any (`checkType` value) type_strs) - ] - Just _ -> [ValidationError path "Invalid 'type' field in schema"] - --- | Check whether a JSON value is of the given JSON Schema type. -checkType :: Text -> Value -> Bool -checkType "null" Null = True -checkType "boolean" (Bool _) = True -checkType "string" (String _) = True -checkType "number" (Number _) = True --- Per JSON Schema, "integer" means the instance is a number with an integral value, --- not limited by machine-sized Int bounds. -checkType "integer" (Number n) = Sci.isInteger n -checkType "array" (Array _) = True -checkType "object" (Object _) = True -checkType _ _ = False - --- | Derive the schema type name corresponding to a value (e.g., "integer"). -describeType :: Value -> Text -describeType Null = "null" -describeType (Bool _) = "boolean" -describeType (String _) = "string" -describeType (Number n) - | Sci.isInteger n = "integer" - | otherwise = "number" -describeType (Array _) = "array" -describeType (Object _) = "object" - --- | Validate the "const" keyword (instance must be exactly equal to the given value). -validateConst :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] -validateConst path km value = - case km KM.!? "const" of - Nothing -> [] - Just const_val -> - [ ValidationError path $ "Expected constant value " <> showJSON const_val <> " but got " <> showJSON value - | value /= const_val - ] - --- | Validate the "enum" keyword (instance must be a member of the given array). -validateEnum :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] -validateEnum path km value = - case km KM.!? "enum" of - Nothing -> [] - Just (Array values) -> - [ValidationError path $ "Value not in enum: " <> showJSON value | not (value `V.elem` values)] - Just _ -> [ValidationError path "Invalid 'enum' field in schema"] - --- | Validate object-related keywords at this location. --- --- Implements: --- - properties: validate each defined property if present --- - patternProperties: validate properties whose names match regex patterns --- - additionalProperties: validate and/or forbid properties not matched above --- - propertyNames: validate each property name as a string instance --- - required: ensure listed properties exist --- - dependentSchemas: when a property exists, apply another schema to the whole object --- - dependentRequired: when a property exists, require additional properties -validateProperties :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateProperties path root km value fuel = - case value of - Object obj -> - let props_schema = km KM.!? "properties" - pattern_props_schema = km KM.!? "patternProperties" - additional_props_schema = km KM.!? "additionalProperties" - property_names_schema = km KM.!? "propertyNames" - required_props = case km KM.!? "required" of - Just (Array arr) -> [t | String t <- V.toList arr] - _ -> [] - - -- Validate properties defined in 'properties' - prop_errors = case props_schema of - Just (Object schema_obj) -> - concat - [ case obj KM.!? key of - Just prop_value -> - validateValue (path <> [K.toText key]) root schema prop_value fuel - Nothing -> [] - | (key, schema) <- KM.toList schema_obj - ] - _ -> [] - - -- Validate properties matching patterns in 'patternProperties' - pattern_prop_errors = case pattern_props_schema of - Just (Object patterns) -> - concat - [ concat - [ if K.toText obj_key =~ K.toText pattern_key - then validateValue (path <> [K.toText obj_key]) root pattern_schema obj_value fuel - else [] - | (pattern_key, pattern_schema) <- KM.toList patterns - ] - | (obj_key, obj_value) <- KM.toList obj - ] - _ -> [] - - -- Determine which properties are handled by properties or patternProperties - handled_by_props = case props_schema of - Just (Object schema_obj) -> KM.keys schema_obj - _ -> [] - handled_by_patterns = case pattern_props_schema of - Just (Object patterns) -> - [ obj_key - | obj_key <- KM.keys obj - , any (\pattern_key -> K.toText obj_key =~ K.toText pattern_key) (KM.keys patterns) - ] - _ -> [] - unhandled_keys = filter (\k -> k `notElem` handled_by_props && k `notElem` handled_by_patterns) (KM.keys obj) - - -- Validate additional properties - additional_errors = case additional_props_schema of - Just (Bool False) -> - [ ValidationError path $ - "Additional property not allowed: " <> K.toText key - | key <- unhandled_keys - ] - Just schema -> - concat - [ case obj KM.!? key of - Just prop_value -> - validateValue (path <> [K.toText key]) root schema prop_value fuel - Nothing -> [] - | key <- unhandled_keys - ] - Nothing -> [] - - -- Validate property names - property_name_errors = case property_names_schema of - Just schema -> - concat - [ let key_value = String (K.toText key) - in validateValue (path <> ["propertyName:" <> K.toText key]) root schema key_value fuel - | key <- KM.keys obj - ] - _ -> [] - - -- Validate required properties - required_errors = - [ ValidationError path $ - "Missing required property: " <> prop - | prop <- required_props - , isNothing (obj KM.!? K.fromText prop) - ] - - -- Handle dependent schemas and required - dependent_errors = validateDependencies path root km obj fuel - in concat [prop_errors, pattern_prop_errors, additional_errors, property_name_errors, required_errors, dependent_errors] - _ -> [] - --- | Validate dependentSchemas and dependentRequired. --- --- - dependentSchemas: if key K present, validate the entire object against a schema S --- - dependentRequired: if key K present, require listed properties to also be present -validateDependencies :: [Text] -> Value -> KM.KeyMap Value -> KM.KeyMap Value -> Int -> [ValidationError] -validateDependencies path root km obj fuel = - let dep_schemas_errors = case km KM.!? "dependentSchemas" of - Just (Object dep_schemas) -> - concat - [ if isJust (obj KM.!? dep_key) - then validateValue path root dep_schema (Object obj) fuel - else [] - | (dep_key, dep_schema) <- KM.toList dep_schemas - ] - _ -> [] - - dep_required_errors = case km KM.!? "dependentRequired" of - Just (Object dep_required) -> - concat - [ if isJust (obj KM.!? dep_key) - then - ( case dep_value of - Array required_arr -> - [ ValidationError path $ - "Property '" <> K.toText dep_key <> "' requires property: " <> req_prop - | String req_prop <- V.toList required_arr - , isNothing (obj KM.!? K.fromText req_prop) - ] - _ -> [] - ) - else [] - | (dep_key, dep_value) <- KM.toList dep_required - ] - _ -> [] - in dep_schemas_errors <> dep_required_errors - --- | Validate array items --- Implements 2020-12 array applicators semantics: --- - "prefixItems": array of schemas applied positionally to the first N items --- - "items": schema applied to all items with index >= N (N = prefixItems length, or 0 if absent) --- - "items": false forbids any items beyond N; if N == 0, array must be empty --- | Validate the "items" applicator for arrays in 2020-12. --- --- Semantics: --- - prefixItems: schemas applied positionally to first N items --- - items: schema for items at index >= N; items=false forbids any items beyond N -validateItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateItems path root km value fuel = - case value of - Array arr -> - let prefix_len = case km KM.!? "prefixItems" of - Just (Array prefixes) -> Just (V.length prefixes) - _ -> Just 0 - n = fromMaybe 0 prefix_len - arr_len = V.length arr - rest_indices = [n .. arr_len - 1] - in case km KM.!? "items" of - Just (Bool False) -> - [ ValidationError path $ - "Array has " - <> T.pack (show arr_len) - <> " items but only " - <> T.pack (show n) - <> " allowed" - | arr_len > n - ] - Just item_schema -> - concat - [ validateValue (path <> [T.pack $ show i]) root item_schema (arr V.! i) fuel - | i <- rest_indices - ] - Nothing -> [] - _ -> [] - --- | Validate the "prefixItems" applicator for arrays (positionally for the first N items). -validatePrefixItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validatePrefixItems path root km value fuel = - case value of - Array arr -> - case km KM.!? "prefixItems" of - Just (Array prefixes) -> - let limit = min (V.length prefixes) (V.length arr) - in concat - [ validateValue (path <> [T.pack $ show i]) root (prefixes V.! i) (arr V.! i) fuel - | i <- [0 .. limit - 1] - ] - _ -> [] - _ -> [] - --- | Validate string constraints: minLength, maxLength, pattern. --- Note: "format" is treated as an annotation and not asserted. -validateStringConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] -validateStringConstraints path km value = - case value of - String str -> - let l = unicodeLength str - in concat - [ case km KM.!? "minLength" of - Just (Number n) - | Just min_len <- Sci.toBoundedInteger n -> - [ ValidationError path $ - "String length " - <> T.pack (show l) - <> " is less than minimum " - <> T.pack (show min_len) - | l < (min_len :: Int) - ] - _ -> [] - , case km KM.!? "maxLength" of - Just (Number n) - | Just max_len <- Sci.toBoundedInteger n -> - ( [ ValidationError path $ - "String length " - <> T.pack (show l) - <> " exceeds maximum " - <> T.pack (show max_len) - | l > (max_len :: Int) - ] - ) - _ -> [] - , case km KM.!? "pattern" of - Just (String pattern) -> - [ValidationError path $ "String does not match pattern: " <> pattern | not (str =~ pattern)] - _ -> [] - -- format validation is optional and can be added later - ] - _ -> [] - --- | Validate numeric constraints: minimum, maximum, exclusiveMinimum, exclusiveMaximum, multipleOf. --- multipleOf is checked exactly using rationals to avoid floating point error. -validateNumberConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] -validateNumberConstraints path km value = - case value of - Number num -> - let fmt :: Scientific -> Text - fmt = T.pack . Sci.formatScientific Sci.Generic Nothing - in concat - [ case km KM.!? "minimum" of - Just (Number min_val) -> - [ ValidationError path $ - "Value " <> fmt num <> " is less than minimum " <> fmt min_val - | num < min_val - ] - _ -> [] - , case km KM.!? "exclusiveMinimum" of - Just (Number min_val) -> - [ ValidationError path $ - "Value " <> fmt num <> " is not greater than exclusiveMinimum " <> fmt min_val - | num <= min_val - ] - _ -> [] - , case km KM.!? "maximum" of - Just (Number max_val) -> - [ ValidationError path $ - "Value " <> fmt num <> " exceeds maximum " <> fmt max_val - | num > max_val - ] - _ -> [] - , case km KM.!? "exclusiveMaximum" of - Just (Number max_val) -> - [ ValidationError path $ - "Value " <> fmt num <> " is not less than exclusiveMaximum " <> fmt max_val - | num >= max_val - ] - _ -> [] - , case km KM.!? "multipleOf" of - Just (Number divisor) -> - ( [ ValidationError path $ - "Value " <> fmt num <> " is not a multiple of " <> fmt divisor - | not (isMultipleOf num divisor) - ] - ) - _ -> [] - ] - _ -> [] - --- | Validate logical combinators: anyOf, oneOf, allOf, not. -validateCombinators :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateCombinators path root km value fuel = - concat - [ validateAnyOf path root km value fuel - , validateOneOf path root km value fuel - , validateAllOf path root km value fuel - , validateNot path root km value fuel - ] - --- | anyOf: valid if at least one subschema validates (merges annotations of matching subschemas). -validateAnyOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateAnyOf path root km value fuel = - case km KM.!? "anyOf" of - Just (Array schemas) -> - let results = [validateValue path root schema value fuel | schema <- V.toList schemas] - in [ValidationError path "Value does not match any of the schemas in 'anyOf'" | not (any null results)] - _ -> [] - --- | oneOf: valid if exactly one subschema validates. -validateOneOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateOneOf path root km value fuel = - case km KM.!? "oneOf" of - Just (Array schemas) -> - let results = [validateValue path root schema value fuel | schema <- V.toList schemas] - valid_count = length $ filter null results - in case valid_count of - 0 -> [ValidationError path "Value does not match any schema in 'oneOf'"] - 1 -> [] - _ -> - [ ValidationError path $ "Value matches " <> T.pack (show valid_count) <> " schemas in 'oneOf' but must match exactly one" - ] - _ -> [] - --- | allOf: valid only if all subschemas validate; accumulates all errors. -validateAllOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateAllOf path root km value fuel = - case km KM.!? "allOf" of - Just (Array schemas) -> - concat [validateValue path root schema value fuel | schema <- V.toList schemas] - _ -> [] - --- | not: valid only if the subschema does not validate. -validateNot :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateNot path root km value fuel = - case km KM.!? "not" of - Just not_schema -> - [ValidationError path "Value matches schema in 'not'" | null (validateValue path root not_schema value fuel)] - _ -> [] - --- | Validate array count/membership constraints: minItems, maxItems, uniqueItems, contains. -validateArrayConstraints :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateArrayConstraints path root km value fuel = - case value of - Array arr -> - concat - [ case km KM.!? "minItems" of - Just (Number n) - | Just min_items <- Sci.toBoundedInteger n -> - [ ValidationError path $ - "Array has " - <> T.pack (show $ V.length arr) - <> " items but minimum is " - <> T.pack (show min_items) - | V.length arr < min_items - ] - _ -> [] - , case km KM.!? "maxItems" of - Just (Number n) - | Just max_items <- Sci.toBoundedInteger n -> - [ ValidationError path $ - "Array has " - <> T.pack (show $ V.length arr) - <> " items but maximum is " - <> T.pack (show max_items) - | V.length arr > max_items - ] - _ -> [] - , case km KM.!? "uniqueItems" of - Just (Bool True) -> - let items = V.toList arr - in [ValidationError path "Array items are not unique" | length items /= length (nub items)] - _ -> [] - , validateContains path root km arr fuel - ] - _ -> [] - --- | Validate contains constraints --- | Validate contains/minContains/maxContains: counts items matching the subschema. --- Note: when "contains" is false, minContains defaults to 1, making any array invalid. -validateContains :: [Text] -> Value -> KM.KeyMap Value -> V.Vector Value -> Int -> [ValidationError] -validateContains path root km arr fuel = - case km KM.!? "contains" of - Nothing -> [] - Just contains_schema -> - let matches = V.filter (\item -> null $ validateValue path root contains_schema item fuel) arr - match_count = V.length matches - min_contains = case km KM.!? "minContains" of - Just (Number n) -> fromMaybe 1 (Sci.toBoundedInteger n) - _ -> 1 - max_contains = case km KM.!? "maxContains" of - Just (Number n) -> Sci.toBoundedInteger n - _ -> Nothing - in concat - [ [ ValidationError path $ - "Array has " - <> T.pack (show match_count) - <> " matching items but minContains is " - <> T.pack (show min_contains) - | match_count < min_contains - ] - , case max_contains of - Just max_cont -> - [ ValidationError path $ - "Array has " - <> T.pack (show match_count) - <> " matching items but maxContains is " - <> T.pack (show max_cont) - | match_count > max_cont - ] - Nothing -> [] - ] - --- | Validate object constraints (minProperties, maxProperties) --- | Validate object property count constraints: minProperties and maxProperties. -validateObjectConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] -validateObjectConstraints path km value = - case value of - Object obj -> - let prop_count = KM.size obj - in concat - [ case km KM.!? "minProperties" of - Just (Number n) - | Just min_props <- Sci.toBoundedInteger n -> - [ ValidationError path $ - "Object has " - <> T.pack (show prop_count) - <> " properties but minimum is " - <> T.pack (show min_props) - | prop_count < min_props - ] - _ -> [] - , case km KM.!? "maxProperties" of - Just (Number n) - | Just max_props <- Sci.toBoundedInteger n -> - [ ValidationError path $ - "Object has " - <> T.pack (show prop_count) - <> " properties but maximum is " - <> T.pack (show max_props) - | prop_count > max_props - ] - _ -> [] - ] - _ -> [] - --- | Validate conditional logic (if/then/else) --- | Validate conditional keywords: if/then/else. -validateConditional :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateConditional path root km value fuel = - case km KM.!? "if" of - Nothing -> [] - Just if_schema -> - let if_matches = null $ validateValue path root if_schema value fuel - in if if_matches - then case km KM.!? "then" of - Just then_schema -> validateValue path root then_schema value fuel - Nothing -> [] - else case km KM.!? "else" of - Just else_schema -> validateValue path root else_schema value fuel - Nothing -> [] - --- | Check if a number is a multiple of another --- Exact multipleOf using rationals (avoids floating point error). --- | Exact multipleOf check using rationals (denominator must be 1). -isMultipleOf :: Scientific -> Scientific -> Bool -isMultipleOf value divisor = - let q = toRational value / toRational divisor - in denominator q == 1 - --- Count Unicode code points (not UTF-16 code units) - --- | Count Unicode code points (not UTF-16 code units) for string length. -unicodeLength :: Text -> Int -unicodeLength = T.foldl' (\n _ -> n + 1) 0 - --- | Helper to show JSON values as text -showJSON :: Value -> Text -showJSON = T.take 100 . T.pack . show - --- | Resolve a local $ref against the root schema using JSON Pointer --- Supports only fragment starting with '#'. External URIs and anchors are not resolved. --- | Resolve a local $ref against the root schema using JSON Pointer. --- Supports only fragments starting with '#'; external URIs/anchors are not resolved. -resolveRef :: Value -> Text -> Maybe Value -resolveRef root ref_path = - case T.uncons ref_path of - Just ('#', rest) -> - -- empty fragment or pointer - if T.null rest - then Just root - else - if T.head rest == '/' - then jsonPointer root (T.tail rest) - else Nothing -- unsupported non-pointer fragment - _ -> Nothing -- unsupported non-fragment refs - --- | Evaluate a JSON Pointer (RFC 6901) against a JSON value. -jsonPointer :: Value -> Text -> Maybe Value -jsonPointer v ptr = - let tokens = map unescapePointer $ T.splitOn "/" ptr - in go v tokens - where - go :: Value -> [Text] -> Maybe Value - go cur [] = Just cur - go (Object km) (t : ts) = - case KM.lookup (K.fromText t) km of - Just nxt -> go nxt ts - Nothing -> Nothing - go (Array arr) (t : ts) - | T.all isDigit t && not (T.null t) = - let i = read (T.unpack t) :: Int - in if i >= 0 && i < V.length arr then go (arr V.! i) ts else Nothing - | otherwise = Nothing - go _ _ = Nothing - - unescapePointer :: Text -> Text - unescapePointer = T.replace "~1" "/" . T.replace "~0" "~" - --- | Validate "unevaluatedProperties": --- Forbids or constrains properties that were not covered by properties, --- patternProperties, or additionalProperties at the current schema location. --- This implementation approximates evaluated sets locally and does not --- perform full annotation merging across nested applicators. -validateUnevaluatedProperties :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateUnevaluatedProperties path root km value fuel = - case (value, km KM.!? "unevaluatedProperties") of - (Object obj, Just uneval_schema) -> - let props_schema = km KM.!? "properties" - pattern_props_schema = km KM.!? "patternProperties" - - props_handled = case props_schema of - Just (Object schema_obj) -> [k | (k, _) <- KM.toList schema_obj, KM.member k obj] - _ -> [] - patterns_handled = case pattern_props_schema of - Just (Object patterns) -> - [ obj_key - | obj_key <- KM.keys obj - , any (\pattern_key -> K.toText obj_key =~ K.toText pattern_key) (KM.keys patterns) - ] - _ -> [] - extras = [k | k <- KM.keys obj, k `notElem` props_handled, k `notElem` patterns_handled] - - -- If additionalProperties is present, consider extras handled by it - extras_handled_by_additional = case km KM.!? "additionalProperties" of - Just _ -> extras - Nothing -> [] - - unevaluated_keys = [k | k <- extras, k `notElem` extras_handled_by_additional] - - applyUnevaluated (Bool False) = - [ ValidationError path $ - "Unevaluated property not allowed: " <> K.toText k - | k <- unevaluated_keys - ] - applyUnevaluated sch = - concat - [ case obj KM.!? k of - Just v -> validateValue (path <> [K.toText k]) root sch v fuel - Nothing -> [] - | k <- unevaluated_keys - ] - in applyUnevaluated uneval_schema - _ -> [] - --- | Validate "unevaluatedItems": --- Applies to array indices not covered by prefixItems, items, or contains When false, any such index is prohibited; when a schema, each such item --- is validated against it. This uses local evaluated-set approximation. -validateUnevaluatedItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] -validateUnevaluatedItems path root km value fuel = - case (value, km KM.!? "unevaluatedItems") of - (Array arr, Just uneval_schema) -> - let arr_len = V.length arr - -- prefix items coverage - prefix_count = case km KM.!? "prefixItems" of - Just (Array prefixes) -> min (V.length prefixes) arr_len - _ -> 0 - prefix_idx = [0 .. prefix_count - 1] - -- items coverage for rest if present - rest_idx = case km KM.!? "items" of - Just _ -> [prefix_count .. arr_len - 1] - Nothing -> [] - -- contains matched indices (optional) - contains_idx = case km KM.!? "contains" of - Nothing -> [] - Just sch -> - [ i - | i <- [0 .. arr_len - 1] - , null $ validateValue path root sch (arr V.! i) fuel - ] - evaluated = nub (prefix_idx <> rest_idx <> contains_idx) - unevaluated = [i | i <- [0 .. arr_len - 1], i `notElem` evaluated] - applyItems (Bool False) = - [ ValidationError path $ - "Unevaluated item not allowed at index " <> T.pack (show i) - | i <- unevaluated - ] - applyItems sch = - concat - [ validateValue (path <> [T.pack (show i)]) root sch (arr V.! i) fuel - | i <- unevaluated - ] - in applyItems uneval_schema - _ -> [] +{- | +Module: JSONSchema.Validation +Copyright: (c) DPella AB 2025 +License: LicenseRef-AllRightsReserved +Maintainer: , + +JSON Schema validation according to JSON Schema 2020-12. + +This module provides validation functions that check if a JSON value +conforms to a given JSON Schema. It supports the core 2020-12 +semantics for validation and applicator keywords ("type", "properties", "patternProperties", +"additionalProperties", "items", "prefixItems", numeric and string +constraints, combinators, and conditionals). Local $ref resolution to JSON Pointers +within the same schema document (including paths under "$defs") is supported. +The "unevaluatedProperties" and "unevaluatedItems" keywords are implemented +with pragmatic semantics at the current instance location (covering properties/items +handled by properties/patternProperties/prefixItems/items/contains). The full +annotation-merging behavior across nested applicators is not implemented. +The Format-Assertion vocabulary is not implemented; the "format" and "content*" +keywords are treated as annotations only, per the 2020-12 specification. + += Usage + +@ +let schema = toJSONSchema (Proxy :: Proxy Person) +let value = object ["name" .= "Alice", "age" .= 30] +validateJSONSchema schema value -- Returns True if valid +@ +-} +module JSONSchema.Validation ( + validateJSONSchema, + ValidationError (..), + validate, + validateWithErrors, +) where + +import Data.Aeson +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Char (isDigit) +import Data.List (nub) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Ratio (denominator) +import Data.Scientific (Scientific) +import Data.Scientific qualified as Sci +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Text.Regex.TDFA ((=~)) +import Text.Regex.TDFA.Text () + +-- | Validation error with context about what failed +data ValidationError = ValidationError + { error_path :: [Text] + -- ^ Path to the failing value (e.g. ["users", "0", "name"]) + , error_message :: Text + -- ^ Description of the validation failure + } + deriving (Show, Eq) + +-- | Simple validation that returns True if the value matches the schema +validateJSONSchema :: Value -> Value -> Bool +validateJSONSchema schema value = null $ validateWithErrors schema value + +-- | Validate with error collection +validate :: Value -> Value -> Either [ValidationError] () +validate schema value = + case validateWithErrors schema value of + [] -> Right () + errs -> Left errs + +{- | Validate and return all errors found for an instance against a schema. +This walks the instance and applies the validation vocabulary for 2020-12, +returning every violation discovered (no short-circuit). +-} +validateWithErrors :: Value -> Value -> [ValidationError] +validateWithErrors schema value = validateValue [] schema schema value maxRefDepth + +-- | Max recursion depth for $ref to avoid infinite loops +maxRefDepth :: Int +maxRefDepth = 256 + +{- | Internal validator with context. + +Parameters: + - path: JSON Pointer-like path to the current instance location + - root: the root schema document (for resolving local $ref) + - schema: the current subschema to apply + - value: the current instance value + - fuel: remaining recursion depth for $ref resolution +-} +validateValue :: [Text] -> Value -> Value -> Value -> Int -> [ValidationError] +validateValue path root schema value fuel = + case schema of + Bool True -> [] -- true schema always validates + Bool False -> [ValidationError path "Schema is false (always fails)"] + Object km -> + -- \$ref short-circuit: if present, ignore other keywords (per spec) + case km KM.!? "$ref" of + Just (String ref_path) -> + if fuel <= 0 + then [ValidationError path "Exceeded $ref resolution depth"] + else case resolveRef root ref_path of + Just ref_schema -> validateValue path root ref_schema value (fuel - 1) + Nothing -> [ValidationError path ("Unresolved $ref: " <> ref_path)] + _ -> validateObject path root km value fuel + _ -> [ValidationError path "Invalid schema: must be a boolean or object"] + +{- | Apply object schema keywords and dispatch to other validators. + +Covers: + - type/const/enum + - Object keywords: properties, patternProperties, additionalProperties, + propertyNames, required, dependentSchemas, dependentRequired + - Array keywords present at this location: prefixItems, items (when instance is array) + - String/Number/Object count constraints + - Combinators: anyOf, oneOf, allOf, not + - Conditionals: if/then/else + - unevaluatedProperties / unevaluatedItems (local, pragmatic semantics) +-} +validateObject :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateObject path root km value fuel = + concat + [ validateType path km value + , validateConst path km value + , validateEnum path km value + , validateProperties path root km value fuel + , validateItems path root km value fuel + , validatePrefixItems path root km value fuel + , validateArrayConstraints path root km value fuel + , validateStringConstraints path km value + , validateNumberConstraints path km value + , validateObjectConstraints path km value + , validateCombinators path root km value fuel + , validateConditional path root km value fuel + , validateUnevaluatedProperties path root km value fuel + , validateUnevaluatedItems path root km value fuel + ] + +{- | Validate the "type" keyword. Supports a single string or an array of types. +Recognized types: null, boolean, string, number, integer, array, object. +-} +validateType :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] +validateType path km value = + case km KM.!? "type" of + Nothing -> [] + Just (String type_str) -> + [ ValidationError path $ "Expected type " <> type_str <> " but got " <> describeType value + | not (checkType type_str value) + ] + Just (Array types) -> + let type_strs = [t | String t <- V.toList types] + in [ ValidationError path $ "Expected one of types " <> T.intercalate ", " type_strs <> " but got " <> describeType value + | not (any (`checkType` value) type_strs) + ] + Just _ -> [ValidationError path "Invalid 'type' field in schema"] + +-- | Check whether a JSON value is of the given JSON Schema type. +checkType :: Text -> Value -> Bool +checkType "null" Null = True +checkType "boolean" (Bool _) = True +checkType "string" (String _) = True +checkType "number" (Number _) = True +-- Per JSON Schema, "integer" means the instance is a number with an integral value, +-- not limited by machine-sized Int bounds. +checkType "integer" (Number n) = Sci.isInteger n +checkType "array" (Array _) = True +checkType "object" (Object _) = True +checkType _ _ = False + +-- | Derive the schema type name corresponding to a value (e.g., "integer"). +describeType :: Value -> Text +describeType Null = "null" +describeType (Bool _) = "boolean" +describeType (String _) = "string" +describeType (Number n) + | Sci.isInteger n = "integer" + | otherwise = "number" +describeType (Array _) = "array" +describeType (Object _) = "object" + +-- | Validate the "const" keyword (instance must be exactly equal to the given value). +validateConst :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] +validateConst path km value = + case km KM.!? "const" of + Nothing -> [] + Just const_val -> + [ ValidationError path $ "Expected constant value " <> showJSON const_val <> " but got " <> showJSON value + | value /= const_val + ] + +-- | Validate the "enum" keyword (instance must be a member of the given array). +validateEnum :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] +validateEnum path km value = + case km KM.!? "enum" of + Nothing -> [] + Just (Array values) -> + [ValidationError path $ "Value not in enum: " <> showJSON value | not (value `V.elem` values)] + Just _ -> [ValidationError path "Invalid 'enum' field in schema"] + +{- | Validate object-related keywords at this location. + +Implements: + - properties: validate each defined property if present + - patternProperties: validate properties whose names match regex patterns + - additionalProperties: validate and/or forbid properties not matched above + - propertyNames: validate each property name as a string instance + - required: ensure listed properties exist + - dependentSchemas: when a property exists, apply another schema to the whole object + - dependentRequired: when a property exists, require additional properties +-} +validateProperties :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateProperties path root km value fuel = + case value of + Object obj -> + let props_schema = km KM.!? "properties" + pattern_props_schema = km KM.!? "patternProperties" + additional_props_schema = km KM.!? "additionalProperties" + property_names_schema = km KM.!? "propertyNames" + required_props = case km KM.!? "required" of + Just (Array arr) -> [t | String t <- V.toList arr] + _ -> [] + + -- Validate properties defined in 'properties' + prop_errors = case props_schema of + Just (Object schema_obj) -> + concat + [ case obj KM.!? key of + Just prop_value -> + validateValue (path <> [K.toText key]) root schema prop_value fuel + Nothing -> [] + | (key, schema) <- KM.toList schema_obj + ] + _ -> [] + + -- Validate properties matching patterns in 'patternProperties' + pattern_prop_errors = case pattern_props_schema of + Just (Object patterns) -> + concat + [ concat + [ if K.toText obj_key =~ K.toText pattern_key + then validateValue (path <> [K.toText obj_key]) root pattern_schema obj_value fuel + else [] + | (pattern_key, pattern_schema) <- KM.toList patterns + ] + | (obj_key, obj_value) <- KM.toList obj + ] + _ -> [] + + -- Determine which properties are handled by properties or patternProperties + handled_by_props = case props_schema of + Just (Object schema_obj) -> KM.keys schema_obj + _ -> [] + handled_by_patterns = case pattern_props_schema of + Just (Object patterns) -> + [ obj_key + | obj_key <- KM.keys obj + , any (\pattern_key -> K.toText obj_key =~ K.toText pattern_key) (KM.keys patterns) + ] + _ -> [] + unhandled_keys = filter (\k -> k `notElem` handled_by_props && k `notElem` handled_by_patterns) (KM.keys obj) + + -- Validate additional properties + additional_errors = case additional_props_schema of + Just (Bool False) -> + [ ValidationError path $ + "Additional property not allowed: " <> K.toText key + | key <- unhandled_keys + ] + Just schema -> + concat + [ case obj KM.!? key of + Just prop_value -> + validateValue (path <> [K.toText key]) root schema prop_value fuel + Nothing -> [] + | key <- unhandled_keys + ] + Nothing -> [] + + -- Validate property names + property_name_errors = case property_names_schema of + Just schema -> + concat + [ let key_value = String (K.toText key) + in validateValue (path <> ["propertyName:" <> K.toText key]) root schema key_value fuel + | key <- KM.keys obj + ] + _ -> [] + + -- Validate required properties + required_errors = + [ ValidationError path $ + "Missing required property: " <> prop + | prop <- required_props + , isNothing (obj KM.!? K.fromText prop) + ] + + -- Handle dependent schemas and required + dependent_errors = validateDependencies path root km obj fuel + in concat [prop_errors, pattern_prop_errors, additional_errors, property_name_errors, required_errors, dependent_errors] + _ -> [] + +{- | Validate dependentSchemas and dependentRequired. + +- dependentSchemas: if key K present, validate the entire object against a schema S +- dependentRequired: if key K present, require listed properties to also be present +-} +validateDependencies :: [Text] -> Value -> KM.KeyMap Value -> KM.KeyMap Value -> Int -> [ValidationError] +validateDependencies path root km obj fuel = + let dep_schemas_errors = case km KM.!? "dependentSchemas" of + Just (Object dep_schemas) -> + concat + [ if isJust (obj KM.!? dep_key) + then validateValue path root dep_schema (Object obj) fuel + else [] + | (dep_key, dep_schema) <- KM.toList dep_schemas + ] + _ -> [] + + dep_required_errors = case km KM.!? "dependentRequired" of + Just (Object dep_required) -> + concat + [ if isJust (obj KM.!? dep_key) + then + ( case dep_value of + Array required_arr -> + [ ValidationError path $ + "Property '" <> K.toText dep_key <> "' requires property: " <> req_prop + | String req_prop <- V.toList required_arr + , isNothing (obj KM.!? K.fromText req_prop) + ] + _ -> [] + ) + else [] + | (dep_key, dep_value) <- KM.toList dep_required + ] + _ -> [] + in dep_schemas_errors <> dep_required_errors + +{- | Validate array items +Implements 2020-12 array applicators semantics: + - "prefixItems": array of schemas applied positionally to the first N items + - "items": schema applied to all items with index >= N (N = prefixItems length, or 0 if absent) + - "items": false forbids any items beyond N; if N == 0, array must be empty +| Validate the "items" applicator for arrays in 2020-12. + +Semantics: + - prefixItems: schemas applied positionally to first N items + - items: schema for items at index >= N; items=false forbids any items beyond N +-} +validateItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateItems path root km value fuel = + case value of + Array arr -> + let prefix_len = case km KM.!? "prefixItems" of + Just (Array prefixes) -> Just (V.length prefixes) + _ -> Just 0 + n = fromMaybe 0 prefix_len + arr_len = V.length arr + rest_indices = [n .. arr_len - 1] + in case km KM.!? "items" of + Just (Bool False) -> + [ ValidationError path $ + "Array has " + <> T.pack (show arr_len) + <> " items but only " + <> T.pack (show n) + <> " allowed" + | arr_len > n + ] + Just item_schema -> + concat + [ validateValue (path <> [T.pack $ show i]) root item_schema (arr V.! i) fuel + | i <- rest_indices + ] + Nothing -> [] + _ -> [] + +-- | Validate the "prefixItems" applicator for arrays (positionally for the first N items). +validatePrefixItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validatePrefixItems path root km value fuel = + case value of + Array arr -> + case km KM.!? "prefixItems" of + Just (Array prefixes) -> + let limit = min (V.length prefixes) (V.length arr) + in concat + [ validateValue (path <> [T.pack $ show i]) root (prefixes V.! i) (arr V.! i) fuel + | i <- [0 .. limit - 1] + ] + _ -> [] + _ -> [] + +{- | Validate string constraints: minLength, maxLength, pattern. +Note: "format" is treated as an annotation and not asserted. +-} +validateStringConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] +validateStringConstraints path km value = + case value of + String str -> + let l = unicodeLength str + in concat + [ case km KM.!? "minLength" of + Just (Number n) + | Just min_len <- Sci.toBoundedInteger n -> + [ ValidationError path $ + "String length " + <> T.pack (show l) + <> " is less than minimum " + <> T.pack (show min_len) + | l < (min_len :: Int) + ] + _ -> [] + , case km KM.!? "maxLength" of + Just (Number n) + | Just max_len <- Sci.toBoundedInteger n -> + ( [ ValidationError path $ + "String length " + <> T.pack (show l) + <> " exceeds maximum " + <> T.pack (show max_len) + | l > (max_len :: Int) + ] + ) + _ -> [] + , case km KM.!? "pattern" of + Just (String pattern) -> + [ValidationError path $ "String does not match pattern: " <> pattern | not (str =~ pattern)] + _ -> [] + -- format validation is optional and can be added later + ] + _ -> [] + +{- | Validate numeric constraints: minimum, maximum, exclusiveMinimum, exclusiveMaximum, multipleOf. +multipleOf is checked exactly using rationals to avoid floating point error. +-} +validateNumberConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] +validateNumberConstraints path km value = + case value of + Number num -> + let fmt :: Scientific -> Text + fmt = T.pack . Sci.formatScientific Sci.Generic Nothing + in concat + [ case km KM.!? "minimum" of + Just (Number min_val) -> + [ ValidationError path $ + "Value " <> fmt num <> " is less than minimum " <> fmt min_val + | num < min_val + ] + _ -> [] + , case km KM.!? "exclusiveMinimum" of + Just (Number min_val) -> + [ ValidationError path $ + "Value " <> fmt num <> " is not greater than exclusiveMinimum " <> fmt min_val + | num <= min_val + ] + _ -> [] + , case km KM.!? "maximum" of + Just (Number max_val) -> + [ ValidationError path $ + "Value " <> fmt num <> " exceeds maximum " <> fmt max_val + | num > max_val + ] + _ -> [] + , case km KM.!? "exclusiveMaximum" of + Just (Number max_val) -> + [ ValidationError path $ + "Value " <> fmt num <> " is not less than exclusiveMaximum " <> fmt max_val + | num >= max_val + ] + _ -> [] + , case km KM.!? "multipleOf" of + Just (Number divisor) -> + ( [ ValidationError path $ + "Value " <> fmt num <> " is not a multiple of " <> fmt divisor + | not (isMultipleOf num divisor) + ] + ) + _ -> [] + ] + _ -> [] + +-- | Validate logical combinators: anyOf, oneOf, allOf, not. +validateCombinators :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateCombinators path root km value fuel = + concat + [ validateAnyOf path root km value fuel + , validateOneOf path root km value fuel + , validateAllOf path root km value fuel + , validateNot path root km value fuel + ] + +-- | anyOf: valid if at least one subschema validates (merges annotations of matching subschemas). +validateAnyOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateAnyOf path root km value fuel = + case km KM.!? "anyOf" of + Just (Array schemas) -> + let results = [validateValue path root schema value fuel | schema <- V.toList schemas] + in [ValidationError path "Value does not match any of the schemas in 'anyOf'" | not (any null results)] + _ -> [] + +-- | oneOf: valid if exactly one subschema validates. +validateOneOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateOneOf path root km value fuel = + case km KM.!? "oneOf" of + Just (Array schemas) -> + let results = [validateValue path root schema value fuel | schema <- V.toList schemas] + valid_count = length $ filter null results + in case valid_count of + 0 -> [ValidationError path "Value does not match any schema in 'oneOf'"] + 1 -> [] + _ -> + [ ValidationError path $ "Value matches " <> T.pack (show valid_count) <> " schemas in 'oneOf' but must match exactly one" + ] + _ -> [] + +-- | allOf: valid only if all subschemas validate; accumulates all errors. +validateAllOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateAllOf path root km value fuel = + case km KM.!? "allOf" of + Just (Array schemas) -> + concat [validateValue path root schema value fuel | schema <- V.toList schemas] + _ -> [] + +-- | not: valid only if the subschema does not validate. +validateNot :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateNot path root km value fuel = + case km KM.!? "not" of + Just not_schema -> + [ValidationError path "Value matches schema in 'not'" | null (validateValue path root not_schema value fuel)] + _ -> [] + +-- | Validate array count/membership constraints: minItems, maxItems, uniqueItems, contains. +validateArrayConstraints :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateArrayConstraints path root km value fuel = + case value of + Array arr -> + concat + [ case km KM.!? "minItems" of + Just (Number n) + | Just min_items <- Sci.toBoundedInteger n -> + [ ValidationError path $ + "Array has " + <> T.pack (show $ V.length arr) + <> " items but minimum is " + <> T.pack (show min_items) + | V.length arr < min_items + ] + _ -> [] + , case km KM.!? "maxItems" of + Just (Number n) + | Just max_items <- Sci.toBoundedInteger n -> + [ ValidationError path $ + "Array has " + <> T.pack (show $ V.length arr) + <> " items but maximum is " + <> T.pack (show max_items) + | V.length arr > max_items + ] + _ -> [] + , case km KM.!? "uniqueItems" of + Just (Bool True) -> + let items = V.toList arr + in [ValidationError path "Array items are not unique" | length items /= length (nub items)] + _ -> [] + , validateContains path root km arr fuel + ] + _ -> [] + +{- | Validate contains constraints +| Validate contains/minContains/maxContains: counts items matching the subschema. +Note: when "contains" is false, minContains defaults to 1, making any array invalid. +-} +validateContains :: [Text] -> Value -> KM.KeyMap Value -> V.Vector Value -> Int -> [ValidationError] +validateContains path root km arr fuel = + case km KM.!? "contains" of + Nothing -> [] + Just contains_schema -> + let matches = V.filter (\item -> null $ validateValue path root contains_schema item fuel) arr + match_count = V.length matches + min_contains = case km KM.!? "minContains" of + Just (Number n) -> fromMaybe 1 (Sci.toBoundedInteger n) + _ -> 1 + max_contains = case km KM.!? "maxContains" of + Just (Number n) -> Sci.toBoundedInteger n + _ -> Nothing + in concat + [ [ ValidationError path $ + "Array has " + <> T.pack (show match_count) + <> " matching items but minContains is " + <> T.pack (show min_contains) + | match_count < min_contains + ] + , case max_contains of + Just max_cont -> + [ ValidationError path $ + "Array has " + <> T.pack (show match_count) + <> " matching items but maxContains is " + <> T.pack (show max_cont) + | match_count > max_cont + ] + Nothing -> [] + ] + +{- | Validate object constraints (minProperties, maxProperties) +| Validate object property count constraints: minProperties and maxProperties. +-} +validateObjectConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError] +validateObjectConstraints path km value = + case value of + Object obj -> + let prop_count = KM.size obj + in concat + [ case km KM.!? "minProperties" of + Just (Number n) + | Just min_props <- Sci.toBoundedInteger n -> + [ ValidationError path $ + "Object has " + <> T.pack (show prop_count) + <> " properties but minimum is " + <> T.pack (show min_props) + | prop_count < min_props + ] + _ -> [] + , case km KM.!? "maxProperties" of + Just (Number n) + | Just max_props <- Sci.toBoundedInteger n -> + [ ValidationError path $ + "Object has " + <> T.pack (show prop_count) + <> " properties but maximum is " + <> T.pack (show max_props) + | prop_count > max_props + ] + _ -> [] + ] + _ -> [] + +{- | Validate conditional logic (if/then/else) +| Validate conditional keywords: if/then/else. +-} +validateConditional :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateConditional path root km value fuel = + case km KM.!? "if" of + Nothing -> [] + Just if_schema -> + let if_matches = null $ validateValue path root if_schema value fuel + in if if_matches + then case km KM.!? "then" of + Just then_schema -> validateValue path root then_schema value fuel + Nothing -> [] + else case km KM.!? "else" of + Just else_schema -> validateValue path root else_schema value fuel + Nothing -> [] + +{- | Check if a number is a multiple of another +Exact multipleOf using rationals (avoids floating point error). +| Exact multipleOf check using rationals (denominator must be 1). +-} +isMultipleOf :: Scientific -> Scientific -> Bool +isMultipleOf value divisor = + let q = toRational value / toRational divisor + in denominator q == 1 + +-- Count Unicode code points (not UTF-16 code units) + +-- | Count Unicode code points (not UTF-16 code units) for string length. +unicodeLength :: Text -> Int +unicodeLength = T.foldl' (\n _ -> n + 1) 0 + +-- | Helper to show JSON values as text +showJSON :: Value -> Text +showJSON = T.take 100 . T.pack . show + +{- | Resolve a local $ref against the root schema using JSON Pointer +Supports only fragment starting with @#@. External URIs and anchors are not resolved. +| Resolve a local $ref against the root schema using JSON Pointer. +Supports only fragments starting with @#@; external URIs/anchors are not resolved. +-} +resolveRef :: Value -> Text -> Maybe Value +resolveRef root ref_path = + case T.uncons ref_path of + Just ('#', rest) -> + -- empty fragment or pointer + if T.null rest + then Just root + else + if T.head rest == '/' + then jsonPointer root (T.tail rest) + else Nothing -- unsupported non-pointer fragment + _ -> Nothing -- unsupported non-fragment refs + +-- | Evaluate a JSON Pointer (RFC 6901) against a JSON value. +jsonPointer :: Value -> Text -> Maybe Value +jsonPointer v ptr = + let tokens = map unescapePointer $ T.splitOn "/" ptr + in go v tokens + where + go :: Value -> [Text] -> Maybe Value + go cur [] = Just cur + go (Object km) (t : ts) = + case KM.lookup (K.fromText t) km of + Just nxt -> go nxt ts + Nothing -> Nothing + go (Array arr) (t : ts) + | T.all isDigit t && not (T.null t) = + let i = read (T.unpack t) :: Int + in if i >= 0 && i < V.length arr then go (arr V.! i) ts else Nothing + | otherwise = Nothing + go _ _ = Nothing + + unescapePointer :: Text -> Text + unescapePointer = T.replace "~1" "/" . T.replace "~0" "~" + +{- | Validate "unevaluatedProperties": +Forbids or constrains properties that were not covered by properties, +patternProperties, or additionalProperties at the current schema location. +This implementation approximates evaluated sets locally and does not +perform full annotation merging across nested applicators. +-} +validateUnevaluatedProperties :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateUnevaluatedProperties path root km value fuel = + case (value, km KM.!? "unevaluatedProperties") of + (Object obj, Just uneval_schema) -> + let props_schema = km KM.!? "properties" + pattern_props_schema = km KM.!? "patternProperties" + + props_handled = case props_schema of + Just (Object schema_obj) -> [k | (k, _) <- KM.toList schema_obj, KM.member k obj] + _ -> [] + patterns_handled = case pattern_props_schema of + Just (Object patterns) -> + [ obj_key + | obj_key <- KM.keys obj + , any (\pattern_key -> K.toText obj_key =~ K.toText pattern_key) (KM.keys patterns) + ] + _ -> [] + extras = [k | k <- KM.keys obj, k `notElem` props_handled, k `notElem` patterns_handled] + + -- If additionalProperties is present, consider extras handled by it + extras_handled_by_additional = case km KM.!? "additionalProperties" of + Just _ -> extras + Nothing -> [] + + unevaluated_keys = [k | k <- extras, k `notElem` extras_handled_by_additional] + + applyUnevaluated (Bool False) = + [ ValidationError path $ + "Unevaluated property not allowed: " <> K.toText k + | k <- unevaluated_keys + ] + applyUnevaluated sch = + concat + [ case obj KM.!? k of + Just v -> validateValue (path <> [K.toText k]) root sch v fuel + Nothing -> [] + | k <- unevaluated_keys + ] + in applyUnevaluated uneval_schema + _ -> [] + +{- | Validate "unevaluatedItems": +Applies to array indices not covered by prefixItems, items, or contains When false, any such index is prohibited; when a schema, each such item +is validated against it. This uses local evaluated-set approximation. +-} +validateUnevaluatedItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError] +validateUnevaluatedItems path root km value fuel = + case (value, km KM.!? "unevaluatedItems") of + (Array arr, Just uneval_schema) -> + let arr_len = V.length arr + -- prefix items coverage + prefix_count = case km KM.!? "prefixItems" of + Just (Array prefixes) -> min (V.length prefixes) arr_len + _ -> 0 + prefix_idx = [0 .. prefix_count - 1] + -- items coverage for rest if present + rest_idx = case km KM.!? "items" of + Just _ -> [prefix_count .. arr_len - 1] + Nothing -> [] + -- contains matched indices (optional) + contains_idx = case km KM.!? "contains" of + Nothing -> [] + Just sch -> + [ i + | i <- [0 .. arr_len - 1] + , null $ validateValue path root sch (arr V.! i) fuel + ] + evaluated = nub (prefix_idx <> rest_idx <> contains_idx) + unevaluated = [i | i <- [0 .. arr_len - 1], i `notElem` evaluated] + applyItems (Bool False) = + [ ValidationError path $ + "Unevaluated item not allowed at index " <> T.pack (show i) + | i <- unevaluated + ] + applyItems sch = + concat + [ validateValue (path <> [T.pack (show i)]) root sch (arr V.! i) fuel + | i <- unevaluated + ] + in applyItems uneval_schema + _ -> [] diff --git a/test/JSONSchema/Spec.hs b/test/JSONSchema/Spec.hs --- a/test/JSONSchema/Spec.hs +++ b/test/JSONSchema/Spec.hs @@ -6,485 +6,708 @@ import Data.Aeson import Data.Aeson.KeyMap qualified as KM -import Data.String (fromString) -import Data.Text (Text) -import Data.Vector (fromList) -import Data.Vector qualified as V -import GHC.Generics (Generic) -import Data.JSON.JSONSchema -import Test.Tasty -import Test.Tasty.HUnit - --- Simple product type (record) -data Person = Person - { name :: Text - , age :: Int - } - deriving (Show, Eq, Generic) - -instance ToJSON Person - -instance ToJSONSchema Person - --- Sum type with non-record and product constructors -data Shape - = Circle Double - | Rectangle Double Double - deriving (Show, Eq, Generic) - -instance ToJSON Shape - -instance ToJSONSchema Shape - --- Sum type with record constructors (tests tagged record encoding) -data Animal - = Dog {dogName :: Text, dogAge :: Int} - | Cat {catName :: Text} - deriving (Show, Eq, Generic) - -instance ToJSON Animal - -instance ToJSONSchema Animal - --- Non-record product with 3 fields (tests prefixItems flattening) -data Triple = Triple Int Text Bool - deriving (Show, Eq, Generic) - -instance ToJSON Triple - -instance ToJSONSchema Triple - --- Recursive non-record sum type for ToJSON encoding test -data RTree - = Leaf Int - | Node RTree RTree - deriving (Show, Eq, Generic) - -instance ToJSON RTree - -instance ToJSONSchema RTree - -tests :: TestTree -tests = - testGroup - "JSON Schema" - [ validationWorks - , validationSpecCoverage - , deriveWorks - , schemaRecursiveWorks - ] - -validationWorks :: TestTree -validationWorks = - testGroup - "Validation Works" - [ testCase "Valid object with required properties" $ do - let schema = - object - [ "type" .= ("object" :: Text) - , "properties" - .= object - [ "name" .= object ["type" .= ("string" :: Text)] - , "age" .= object ["type" .= ("integer" :: Text)] - ] - , "required" .= (["name", "age"] :: [Text]) - , "additionalProperties" .= False - ] - value = object ["name" .= ("Alice" :: Text), "age" .= (30 :: Int)] - assertBool "Expected valid JSON for schema" (validateJSONSchema schema value) - , testCase "Missing required property fails" $ do - let schema = - object - [ "type" .= ("object" :: Text) - , "properties" - .= object - [ "name" .= object ["type" .= ("string" :: Text)] - , "age" .= object ["type" .= ("integer" :: Text)] - ] - , "required" .= (["name", "age"] :: [Text]) - , "additionalProperties" .= False - ] - value = object ["name" .= ("Alice" :: Text)] - assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value) - , testCase "Wrong type fails" $ do - let schema = - object - [ "type" .= ("object" :: Text) - , "properties" - .= object - [ "name" .= object ["type" .= ("string" :: Text)] - , "age" .= object ["type" .= ("integer" :: Text)] - ] - , "required" .= (["name", "age"] :: [Text]) - , "additionalProperties" .= False - ] - value = object ["name" .= ("Alice" :: Text), "age" .= ("30" :: Text)] - assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value) - , testCase "Additional property rejected when additionalProperties=false" $ do - let schema = - object - [ "type" .= ("object" :: Text) - , "properties" - .= object - [ "name" .= object ["type" .= ("string" :: Text)] - , "age" .= object ["type" .= ("integer" :: Text)] - ] - , "required" .= (["name", "age"] :: [Text]) - , "additionalProperties" .= False - ] - value = object ["name" .= ("Alice" :: Text), "age" .= (30 :: Int), "extra" .= (True :: Bool)] - assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value) - , testCase "items=false with no prefixItems forbids any items" $ do - let schema = object ["type" .= ("array" :: Text), "items" .= False] - assertBool "[] should validate" (validateJSONSchema schema (Array mempty)) - assertBool "[1] should not validate" (not $ validateJSONSchema schema (toJSON ([1 :: Int] :: [Int]))) - , testCase "items applies only to items after prefixItems" $ do - let schema = - object - [ "type" .= ("array" :: Text) - , "prefixItems" .= [object ["type" .= ("integer" :: Text)]] - , "items" .= object ["type" .= ("string" :: Text)] - ] - j1 = toJSON ([1 :: Int] :: [Int]) - j2 = Array (fromList [Number 1, String "x"]) - j3 = toJSON ([1 :: Int, 2] :: [Int]) - assertBool "[1] valid (no rest)" (validateJSONSchema schema j1) - assertBool "[1, \"x\"] valid (rest string)" (validateJSONSchema schema j2) - assertBool "[1, 2] invalid (rest not string)" (not $ validateJSONSchema schema j3) - ] - --- A comprehensive set of tests covering the 2020-12 validation vocabulary -validationSpecCoverage :: TestTree -validationSpecCoverage = - testGroup - "Validation Spec Coverage" - [ -- type - testCase "type: integer vs number" $ do - let sInt = object ["type" .= ("integer" :: Text)] - assertBool "3 integer" (validateJSONSchema sInt (Number 3)) - assertBool "3.5 not integer" (not $ validateJSONSchema sInt (Number 3.5)) - , testCase "type: array of types" $ do - let s = object ["type" .= (["string", "null"] :: [Text])] - assertBool "string ok" (validateJSONSchema s (String "x")) - assertBool "null ok" (validateJSONSchema s Null) - assertBool "bool not ok" (not $ validateJSONSchema s (Bool True)) - , -- const, enum - testCase "const exact match" $ do - let s = object ["const" .= object ["a" .= (1 :: Int)]] - assertBool "match" (validateJSONSchema s (object ["a" .= (1 :: Int)])) - assertBool "no match" (not $ validateJSONSchema s (object ["a" .= (2 :: Int)])) - , testCase "enum membership" $ do - let s = object ["enum" .= ([String "a", String "b"] :: [Value])] - assertBool "a ok" (validateJSONSchema s (String "a")) - assertBool "c not ok" (not $ validateJSONSchema s (String "c")) - , -- string: minLength, maxLength, pattern - testCase "string length counts code points" $ do - let s = object ["type" .= ("string" :: Text), "minLength" .= (1 :: Int), "maxLength" .= (1 :: Int)] - assertBool "emoji single code point ok" (validateJSONSchema s (String "😊")) - , testCase "string pattern" $ do - let s = object ["type" .= ("string" :: Text), "pattern" .= ("^[a-z]+$" :: Text)] - assertBool "lowercase ok" (validateJSONSchema s (String "abc")) - assertBool "uppercase not ok" (not $ validateJSONSchema s (String "Abc")) - , -- number: minimum/maximum/exclusive*/multipleOf - testCase "number bounds inclusive/exclusive" $ do - let s = - object - [ "type" .= ("number" :: Text) - , "minimum" .= (1 :: Int) - , "exclusiveMaximum" .= (3 :: Int) - ] - assertBool "1 ok" (validateJSONSchema s (Number 1)) - assertBool "2.9 ok" (validateJSONSchema s (Number 2.9)) - assertBool "3 not ok" (not $ validateJSONSchema s (Number 3)) - , testCase "minimum respects large integers" $ do - let s = - object - [ "type" .= ("integer" :: Text) - , "minimum" .= Number 9007199254740993 - ] - assertBool "just below fails" (not $ validateJSONSchema s (Number 9007199254740992)) - assertBool "threshold passes" (validateJSONSchema s (Number 9007199254740993)) - , testCase "exclusiveMaximum handles high precision decimals" $ do - let bound = Number 0.12345678901234567890 - s = - object - [ "type" .= ("number" :: Text) - , "exclusiveMaximum" .= bound - ] - assertBool "slightly smaller ok" (validateJSONSchema s (Number 0.12345678901234567889)) - assertBool "equal fails" (not $ validateJSONSchema s bound) - assertBool "larger fails" (not $ validateJSONSchema s (Number 0.12345678901234567891)) - , testCase "multipleOf exact with rational" $ do - let s = object ["type" .= ("number" :: Text), "multipleOf" .= (0.1 :: Double)] - assertBool "0.3 ok" (validateJSONSchema s (Number 0.3)) - assertBool "0.31 not ok" (not $ validateJSONSchema s (Number 0.31)) - , -- array: minItems/maxItems/uniqueItems/contains/minContains/maxContains - testCase "array min/max items" $ do - let s = object ["type" .= ("array" :: Text), "minItems" .= (1 :: Int), "maxItems" .= (2 :: Int)] - assertBool "[1] ok" (validateJSONSchema s (toJSON ([1 :: Int] :: [Int]))) - assertBool "[] not ok" (not $ validateJSONSchema s (toJSON ([] :: [Int]))) - assertBool "[1,2,3] not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int, 2, 3] :: [Int]))) - , testCase "uniqueItems deep equality" $ do - let s = object ["type" .= ("array" :: Text), "uniqueItems" .= True] - assertBool - "unique ok" - (validateJSONSchema s (toJSON ([object ["a" .= (1 :: Int)], object ["a" .= (2 :: Int)]] :: [Value]))) - assertBool - "duplicate not ok" - (not $ validateJSONSchema s (toJSON ([object ["a" .= (1 :: Int)], object ["a" .= (1 :: Int)]] :: [Value]))) - , testCase "contains with min/maxContains" $ do - let s = - object - [ "type" .= ("array" :: Text) - , "contains" .= object ["type" .= ("integer" :: Text)] - , "minContains" .= (2 :: Int) - , "maxContains" .= (3 :: Int) - ] - assertBool "two ints ok" (validateJSONSchema s (toJSON ([Number 1, String "x", Number 2] :: [Value]))) - assertBool "one int not ok" (not $ validateJSONSchema s (toJSON ([Number 1, String "x"] :: [Value]))) - assertBool "four ints not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int, 2, 3, 4] :: [Int]))) - , testCase "contains=false forbids any matches by minContains default" $ do - let s = object ["type" .= ("array" :: Text), "contains" .= False] - assertBool "[] not ok (minContains defaults to 1)" (not $ validateJSONSchema s (toJSON ([] :: [Int]))) - -- default minContains is 1 when contains is present, so any match is impossible - assertBool "[1] not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int] :: [Int]))) - , testCase "unevaluatedItems=false forbids trailing items not covered by prefix/items" $ do - let s = - object - [ "type" .= ("array" :: Text) - , "prefixItems" .= toJSON ([object ["type" .= ("integer" :: Text)]] :: [Value]) - , "unevaluatedItems" .= False - ] - assertBool "[1] ok" (validateJSONSchema s (toJSON ([1 :: Int] :: [Int]))) - assertBool "[1, \"x\"] not ok" (not $ validateJSONSchema s (toJSON ([Number 1, String "x"] :: [Value]))) - , -- object: required/properties/patternProperties/additionalProperties/propertyNames/min/max props - testCase "required properties enforced" $ do - let s = - object - [ "type" .= ("object" :: Text) - , "properties" .= object ["a" .= object ["type" .= ("integer" :: Text)]] - , "required" .= (["a"] :: [Text]) - ] - assertBool "present ok" (validateJSONSchema s (object ["a" .= (1 :: Int)])) - assertBool "missing not ok" (not $ validateJSONSchema s (object [])) - , testCase "patternProperties match" $ do - let s = - object - [ "type" .= ("object" :: Text) - , "patternProperties" .= object ["^x-" .= object ["type" .= ("string" :: Text)]] - ] - assertBool "x-foo ok" (validateJSONSchema s (object ["x-foo" .= ("bar" :: Text)])) - assertBool "x-foo wrong type" (not $ validateJSONSchema s (object ["x-foo" .= (1 :: Int)])) - , testCase "additionalProperties schema applies to extras" $ do - let s = - object - [ "type" .= ("object" :: Text) - , "properties" .= object ["a" .= object ["type" .= ("integer" :: Text)]] - , "additionalProperties" .= object ["type" .= ("string" :: Text)] - ] - assertBool "extra string ok" (validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= ("x" :: Text)])) - assertBool "extra int not ok" (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)])) - , testCase "unevaluatedProperties=false forbids extras not covered by props/patterns" $ do - let s = - object - [ "type" .= ("object" :: Text) - , "properties" .= object ["a" .= object []] - , "unevaluatedProperties" .= False - ] - assertBool "only a ok" (validateJSONSchema s (object ["a" .= (1 :: Int)])) - assertBool "extra b not ok" (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)])) - , testCase "local $ref into $defs resolves and validates" $ do - let s = - object - [ "$defs" .= object ["posInt" .= object ["type" .= ("integer" :: Text), "minimum" .= (0 :: Int)]] - , "type" .= ("object" :: Text) - , "properties" .= object ["age" .= object ["$ref" .= ("#/$defs/posInt" :: Text)]] - , "required" .= (["age"] :: [Text]) - ] - assertBool "age=5 ok" (validateJSONSchema s (object ["age" .= (5 :: Int)])) - assertBool "age=-1 not ok" (not $ validateJSONSchema s (object ["age" .= (-1 :: Int)])) - , testCase "unevaluatedItems with contains marks matches as evaluated; remainder must satisfy schema" $ do - let s = - object - [ "type" .= ("array" :: Text) - , "contains" .= object ["type" .= ("integer" :: Text)] - , "minContains" .= (1 :: Int) - , "unevaluatedItems" .= object ["type" .= ("string" :: Text)] - ] - assertBool "[1, \"x\", \"y\"] ok" (validateJSONSchema s (toJSON ([Number 1, String "x", String "y"] :: [Value]))) - assertBool - "[1, false] not ok (false not string)" - (not $ validateJSONSchema s (toJSON ([Number 1, Bool False] :: [Value]))) - , testCase "propertyNames constraint" $ do - let s = object ["type" .= ("object" :: Text), "propertyNames" .= object ["pattern" .= ("^[a-z]+$" :: Text)]] - assertBool "lowercase key ok" (validateJSONSchema s (object ["abc" .= (1 :: Int)])) - assertBool "uppercase key not ok" (not $ validateJSONSchema s (object ["Abc" .= (1 :: Int)])) - , testCase "min/max properties" $ do - let s = object ["type" .= ("object" :: Text), "minProperties" .= (1 :: Int), "maxProperties" .= (2 :: Int)] - assertBool "one ok" (validateJSONSchema s (object ["a" .= (1 :: Int)])) - assertBool "none not ok" (not $ validateJSONSchema s (object [])) - assertBool - "three not ok" - (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int), "c" .= (3 :: Int)])) - , -- dependentRequired / dependentSchemas - testCase "dependentRequired enforces required when key present" $ do - let s = - object - [ "type" .= ("object" :: Text) - , "dependentRequired" .= object ["credit_card" .= (["billing_address"] :: [Text])] - ] - assertBool "missing credit_card ok" (validateJSONSchema s (object ["name" .= ("Bob" :: Text)])) - assertBool "present without dependency not ok" (not $ validateJSONSchema s (object ["credit_card" .= ("123" :: Text)])) - assertBool - "present with dependency ok" - (validateJSONSchema s (object ["credit_card" .= ("123" :: Text), "billing_address" .= ("A" :: Text)])) - , testCase "dependentSchemas applies object schema when key present" $ do - let dep = object ["properties" .= object ["a" .= object ["const" .= (1 :: Int)]], "required" .= (["a"] :: [Text])] - s = object ["type" .= ("object" :: Text), "dependentSchemas" .= object ["flag" .= dep]] - assertBool "no flag ok" (validateJSONSchema s (object ["a" .= (2 :: Int)])) - assertBool "flag requires a=1" (validateJSONSchema s (object ["flag" .= True, "a" .= (1 :: Int)])) - assertBool "flag with wrong a not ok" (not $ validateJSONSchema s (object ["flag" .= True, "a" .= (2 :: Int)])) - , -- combinators - testCase "anyOf passes if any schema matches" $ do - let s = object ["anyOf" .= ([object ["type" .= ("string" :: Text)], object ["type" .= ("integer" :: Text)]] :: [Value])] - assertBool "int ok" (validateJSONSchema s (Number 3)) - , testCase "oneOf exactly one" $ do - let s = object ["oneOf" .= ([object ["type" .= ("number" :: Text)], object ["minimum" .= (0 :: Int)]] :: [Value])] - -- number 3 matches both type=number and minimum=0; should fail - assertBool "matches both not ok" (not $ validateJSONSchema s (Number 3)) - , testCase "allOf accumulates constraints" $ do - let s = object ["allOf" .= ([object ["type" .= ("number" :: Text)], object ["maximum" .= (5 :: Int)]] :: [Value])] - assertBool "6 not ok" (not $ validateJSONSchema s (Number 6)) - , testCase "not inverts" $ do - let s = object ["not" .= object ["type" .= ("null" :: Text)]] - assertBool "null not ok" (not $ validateJSONSchema s Null) - , -- conditionals if/then/else - testCase "if/then/else branching" $ do - let s = - object - [ "if" .= object ["properties" .= object ["a" .= object ["const" .= True]]] - , "then" .= object ["required" .= (["b"] :: [Text])] - , "else" .= object ["required" .= (["c"] :: [Text])] - ] - assertBool "a=true requires b" (not $ validateJSONSchema s (object ["a" .= True])) - assertBool "a=false requires c" (not $ validateJSONSchema s (object ["a" .= False])) - , -- format and content keywords are annotations in 2020-12: do not assert by default - testCase "format does not assert by default" $ do - let s = object ["type" .= ("string" :: Text), "format" .= ("email" :: Text)] - assertBool "non-email still valid (annotation only)" (validateJSONSchema s (String "not-an-email")) - , testCase "content keywords are annotations only" $ do - let s = - object - [ "type" .= ("string" :: Text) - , "contentEncoding" .= ("base64" :: Text) - , "contentMediaType" .= ("image/png" :: Text) - ] - -- we do not auto-decode/validate: annotation only - assertBool "arbitrary string still valid" (validateJSONSchema s (String "@@not-base64@@")) - ] - -deriveWorks :: TestTree -deriveWorks = - testGroup - "Derive Works (Aeson JSON validates against derived schema)" - [ testCase "Person record encodes and validates" $ do - let schema = toJSONSchema (Proxy :: Proxy Person) - jPerson = toJSON (Person "Bob" 42) - assertBool "Person JSON should validate against derived schema" (validateJSONSchema schema jPerson) - assertBool "Person schema should reject missing fields" (not $ validateJSONSchema schema (object [])) - , testCase "Shape sum (non-record) constructors validate" $ do - let schema = toJSONSchema (Proxy :: Proxy Shape) - j1 = toJSON (Circle 1.5) - j2 = toJSON (Rectangle 2.3 4.5) - assertBool "Circle JSON should validate" (validateJSONSchema schema j1) - assertBool "Rectangle JSON should validate" (validateJSONSchema schema j2) - , testCase "Animal sum (record) constructors validate" $ do - let schema = toJSONSchema (Proxy :: Proxy Animal) - j1 = toJSON (Dog "Fido" 5) - j2 = toJSON (Cat "Whiskers") - assertBool "Dog JSON should validate" (validateJSONSchema schema j1) - assertBool "Cat JSON should validate" (validateJSONSchema schema j2) - assertBool "Dog schema should reject missing required fields" - (not $ - validateJSONSchema schema - (object ["tag" .= ("Dog" :: Text)]) - ) - assertBool "Dog schema should reject missing tag" - (not $ - validateJSONSchema schema - (object ["dogName" .= ("Fido" :: Text), "dogAge" .= (5 :: Int)]) - ) - , testCase "Triple non-record product flattens and validates" $ do - let schema = toJSONSchema (Proxy :: Proxy Triple) - jTriple = toJSON (Triple 1 "a" True) - assertBool "Triple JSON should validate" (validateJSONSchema schema jTriple) - , testCase "Maybe and list instances validate via derived schema" $ do - let maybeSchema = toJSONSchema (Proxy :: Proxy (Maybe Int)) - listSchema = toJSONSchema (Proxy :: Proxy [Text]) - assertBool "Just Int validates" (validateJSONSchema maybeSchema (toJSON (Just (3 :: Int)))) - assertBool "Nothing validates" (validateJSONSchema maybeSchema Null) - assertBool "[Text] validates" (validateJSONSchema listSchema (toJSON (["x", "y"] :: [Text]))) - , testCase "Either schema enforces discriminator semantics" $ do - let schema = toJSONSchema (Proxy :: Proxy (Either Int Text)) - leftVal = toJSON (Left (3 :: Int) :: Either Int Text) - rightVal = toJSON (Right ("hi" :: Text) :: Either Int Text) - emptyObj = object [] - bothObj = - object - [ "Left" .= (1 :: Int) - , "Right" .= ("oops" :: Text) - ] - assertBool "Left JSON should validate" (validateJSONSchema schema leftVal) - assertBool "Right JSON should validate" (validateJSONSchema schema rightVal) - assertBool "Empty object should be rejected" (not $ validateJSONSchema schema emptyObj) - assertBool "Object with both constructors should be rejected" (not $ validateJSONSchema schema bothObj) - ] - -schemaRecursiveWorks :: TestTree -schemaRecursiveWorks = - testGroup - "ToJSONSchema Works (recursive type emits $ref)" - [ testCase "Derived schema uses $defs and $ref for recursion" $ do - let s = toJSONSchema (Proxy :: Proxy RTree) - -- Top-level must be an object with $defs (and ideally $ref) - case s of - Object km -> do - -- \$defs contains RTree definition, and its Node constructor contains $ref back - case km KM.!? "$defs" of - Just (Object defs) -> case defs KM.!? fromString "RTree" of - Just (Object rtreeDef) -> do - -- look for 'anyOf' containing Node/Leaf. In Node path, ensure children $ref - case rtreeDef KM.!? fromString "anyOf" of - Just (Array alts) -> do - -- At least one alternative should be the tagged Node object with contents array - let hasRefBack = - V.any - ( \v -> case v of - Object km2 -> case km2 KM.!? fromString "properties" of - Just (Object props) -> case props KM.!? fromString "contents" of - Just (Object cont) -> case cont KM.!? fromString "prefixItems" of - Just (Array pfi) -> - V.all - ( \piV -> case piV of - Object o -> case o KM.!? fromString "$ref" of - Just (String r) -> r == "#/$defs/RTree" - _ -> False - _ -> False - ) - pfi - _ -> False - _ -> False - _ -> False - _ -> False - ) - alts - assertBool "Node contents references back to RTree via $ref" hasRefBack - _ -> assertFailure "RTree def missing anyOf" - _ -> assertFailure "$defs.RTree missing" - _ -> assertFailure "$defs missing" - _ -> assertFailure "Top-level schema should be object" - , testCase "Recursive value validates against derived schema" $ do - let s = toJSONSchema (Proxy :: Proxy RTree) - j = toJSON (Node (Leaf 1) (Leaf 2)) - assertBool "recursive value should validate" (validateJSONSchema s j) +import Data.JSON.JSONSchema +import Data.String (fromString) +import Data.Text (Text) +import Data.Vector (fromList) +import Data.Vector qualified as V +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +-- Simple product type (record) +data Person = Person + { name :: Text + , age :: Int + } + deriving (Show, Eq, Generic) + +instance ToJSON Person + +instance ToJSONSchema Person + +-- Sum type with non-record and product constructors +data Shape + = Circle Double + | Rectangle Double Double + deriving (Show, Eq, Generic) + +instance ToJSON Shape + +instance ToJSONSchema Shape + +-- Sum type with record constructors (tests tagged record encoding) +data Animal + = Dog {dogName :: Text, dogAge :: Int} + | Cat {catName :: Text} + deriving (Show, Eq, Generic) + +instance ToJSON Animal + +instance ToJSONSchema Animal + +-- Non-record product with 3 fields (tests prefixItems flattening) +data Triple = Triple Int Text Bool + deriving (Show, Eq, Generic) + +instance ToJSON Triple + +instance ToJSONSchema Triple + +-- Recursive non-record sum type for ToJSON encoding test +data RTree + = Leaf Int + | Node RTree RTree + deriving (Show, Eq, Generic) + +instance ToJSON RTree + +instance ToJSONSchema RTree + +tests :: TestTree +tests = + testGroup + "JSON Schema" + [ validationWorks + , validationSpecCoverage + , deriveWorks + , schemaRecursiveWorks + , valueDirectedWorks + ] + +validationWorks :: TestTree +validationWorks = + testGroup + "Validation Works" + [ testCase "Valid object with required properties" $ do + let schema = + object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "name" .= object ["type" .= ("string" :: Text)] + , "age" .= object ["type" .= ("integer" :: Text)] + ] + , "required" .= (["name", "age"] :: [Text]) + , "additionalProperties" .= False + ] + value = object ["name" .= ("Alice" :: Text), "age" .= (30 :: Int)] + assertBool "Expected valid JSON for schema" (validateJSONSchema schema value) + , testCase "Missing required property fails" $ do + let schema = + object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "name" .= object ["type" .= ("string" :: Text)] + , "age" .= object ["type" .= ("integer" :: Text)] + ] + , "required" .= (["name", "age"] :: [Text]) + , "additionalProperties" .= False + ] + value = object ["name" .= ("Alice" :: Text)] + assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value) + , testCase "Wrong type fails" $ do + let schema = + object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "name" .= object ["type" .= ("string" :: Text)] + , "age" .= object ["type" .= ("integer" :: Text)] + ] + , "required" .= (["name", "age"] :: [Text]) + , "additionalProperties" .= False + ] + value = object ["name" .= ("Alice" :: Text), "age" .= ("30" :: Text)] + assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value) + , testCase "Additional property rejected when additionalProperties=false" $ do + let schema = + object + [ "type" .= ("object" :: Text) + , "properties" + .= object + [ "name" .= object ["type" .= ("string" :: Text)] + , "age" .= object ["type" .= ("integer" :: Text)] + ] + , "required" .= (["name", "age"] :: [Text]) + , "additionalProperties" .= False + ] + value = object ["name" .= ("Alice" :: Text), "age" .= (30 :: Int), "extra" .= (True :: Bool)] + assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value) + , testCase "items=false with no prefixItems forbids any items" $ do + let schema = object ["type" .= ("array" :: Text), "items" .= False] + assertBool "[] should validate" (validateJSONSchema schema (Array mempty)) + assertBool "[1] should not validate" (not $ validateJSONSchema schema (toJSON ([1 :: Int] :: [Int]))) + , testCase "items applies only to items after prefixItems" $ do + let schema = + object + [ "type" .= ("array" :: Text) + , "prefixItems" .= [object ["type" .= ("integer" :: Text)]] + , "items" .= object ["type" .= ("string" :: Text)] + ] + j1 = toJSON ([1 :: Int] :: [Int]) + j2 = Array (fromList [Number 1, String "x"]) + j3 = toJSON ([1 :: Int, 2] :: [Int]) + assertBool "[1] valid (no rest)" (validateJSONSchema schema j1) + assertBool "[1, \"x\"] valid (rest string)" (validateJSONSchema schema j2) + assertBool "[1, 2] invalid (rest not string)" (not $ validateJSONSchema schema j3) + , testCase "detailed-error API is reachable via the umbrella (#1)" $ do + let schema = object ["type" .= ("integer" :: Text)] + assertBool "validateWithErrors reports a violation" (not (null (validateWithErrors schema (String "x")))) + case validate schema (String "x") of + Left (ValidationError _ _ : _) -> pure () + Left [] -> assertFailure "expected at least one ValidationError" + Right () -> assertFailure "expected validation to fail" + ] + +-- A comprehensive set of tests covering the 2020-12 validation vocabulary +validationSpecCoverage :: TestTree +validationSpecCoverage = + testGroup + "Validation Spec Coverage" + [ -- type + testCase "type: integer vs number" $ do + let sInt = object ["type" .= ("integer" :: Text)] + assertBool "3 integer" (validateJSONSchema sInt (Number 3)) + assertBool "3.5 not integer" (not $ validateJSONSchema sInt (Number 3.5)) + , testCase "type: array of types" $ do + let s = object ["type" .= (["string", "null"] :: [Text])] + assertBool "string ok" (validateJSONSchema s (String "x")) + assertBool "null ok" (validateJSONSchema s Null) + assertBool "bool not ok" (not $ validateJSONSchema s (Bool True)) + , -- const, enum + testCase "const exact match" $ do + let s = object ["const" .= object ["a" .= (1 :: Int)]] + assertBool "match" (validateJSONSchema s (object ["a" .= (1 :: Int)])) + assertBool "no match" (not $ validateJSONSchema s (object ["a" .= (2 :: Int)])) + , testCase "enum membership" $ do + let s = object ["enum" .= ([String "a", String "b"] :: [Value])] + assertBool "a ok" (validateJSONSchema s (String "a")) + assertBool "c not ok" (not $ validateJSONSchema s (String "c")) + , -- string: minLength, maxLength, pattern + testCase "string length counts code points" $ do + let s = object ["type" .= ("string" :: Text), "minLength" .= (1 :: Int), "maxLength" .= (1 :: Int)] + assertBool "emoji single code point ok" (validateJSONSchema s (String "😊")) + , testCase "string pattern" $ do + let s = object ["type" .= ("string" :: Text), "pattern" .= ("^[a-z]+$" :: Text)] + assertBool "lowercase ok" (validateJSONSchema s (String "abc")) + assertBool "uppercase not ok" (not $ validateJSONSchema s (String "Abc")) + , -- number: minimum/maximum/exclusive*/multipleOf + testCase "number bounds inclusive/exclusive" $ do + let s = + object + [ "type" .= ("number" :: Text) + , "minimum" .= (1 :: Int) + , "exclusiveMaximum" .= (3 :: Int) + ] + assertBool "1 ok" (validateJSONSchema s (Number 1)) + assertBool "2.9 ok" (validateJSONSchema s (Number 2.9)) + assertBool "3 not ok" (not $ validateJSONSchema s (Number 3)) + , testCase "minimum respects large integers" $ do + let s = + object + [ "type" .= ("integer" :: Text) + , "minimum" .= Number 9007199254740993 + ] + assertBool "just below fails" (not $ validateJSONSchema s (Number 9007199254740992)) + assertBool "threshold passes" (validateJSONSchema s (Number 9007199254740993)) + , testCase "exclusiveMaximum handles high precision decimals" $ do + let bound = Number 0.12345678901234567890 + s = + object + [ "type" .= ("number" :: Text) + , "exclusiveMaximum" .= bound + ] + assertBool "slightly smaller ok" (validateJSONSchema s (Number 0.12345678901234567889)) + assertBool "equal fails" (not $ validateJSONSchema s bound) + assertBool "larger fails" (not $ validateJSONSchema s (Number 0.12345678901234567891)) + , testCase "multipleOf exact with rational" $ do + let s = object ["type" .= ("number" :: Text), "multipleOf" .= (0.1 :: Double)] + assertBool "0.3 ok" (validateJSONSchema s (Number 0.3)) + assertBool "0.31 not ok" (not $ validateJSONSchema s (Number 0.31)) + , -- array: minItems/maxItems/uniqueItems/contains/minContains/maxContains + testCase "array min/max items" $ do + let s = object ["type" .= ("array" :: Text), "minItems" .= (1 :: Int), "maxItems" .= (2 :: Int)] + assertBool "[1] ok" (validateJSONSchema s (toJSON ([1 :: Int] :: [Int]))) + assertBool "[] not ok" (not $ validateJSONSchema s (toJSON ([] :: [Int]))) + assertBool "[1,2,3] not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int, 2, 3] :: [Int]))) + , testCase "uniqueItems deep equality" $ do + let s = object ["type" .= ("array" :: Text), "uniqueItems" .= True] + assertBool + "unique ok" + (validateJSONSchema s (toJSON ([object ["a" .= (1 :: Int)], object ["a" .= (2 :: Int)]] :: [Value]))) + assertBool + "duplicate not ok" + (not $ validateJSONSchema s (toJSON ([object ["a" .= (1 :: Int)], object ["a" .= (1 :: Int)]] :: [Value]))) + , testCase "contains with min/maxContains" $ do + let s = + object + [ "type" .= ("array" :: Text) + , "contains" .= object ["type" .= ("integer" :: Text)] + , "minContains" .= (2 :: Int) + , "maxContains" .= (3 :: Int) + ] + assertBool "two ints ok" (validateJSONSchema s (toJSON ([Number 1, String "x", Number 2] :: [Value]))) + assertBool "one int not ok" (not $ validateJSONSchema s (toJSON ([Number 1, String "x"] :: [Value]))) + assertBool "four ints not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int, 2, 3, 4] :: [Int]))) + , testCase "contains=false forbids any matches by minContains default" $ do + let s = object ["type" .= ("array" :: Text), "contains" .= False] + assertBool "[] not ok (minContains defaults to 1)" (not $ validateJSONSchema s (toJSON ([] :: [Int]))) + -- default minContains is 1 when contains is present, so any match is impossible + assertBool "[1] not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int] :: [Int]))) + , testCase "unevaluatedItems=false forbids trailing items not covered by prefix/items" $ do + let s = + object + [ "type" .= ("array" :: Text) + , "prefixItems" .= toJSON ([object ["type" .= ("integer" :: Text)]] :: [Value]) + , "unevaluatedItems" .= False + ] + assertBool "[1] ok" (validateJSONSchema s (toJSON ([1 :: Int] :: [Int]))) + assertBool "[1, \"x\"] not ok" (not $ validateJSONSchema s (toJSON ([Number 1, String "x"] :: [Value]))) + , -- object: required/properties/patternProperties/additionalProperties/propertyNames/min/max props + testCase "required properties enforced" $ do + let s = + object + [ "type" .= ("object" :: Text) + , "properties" .= object ["a" .= object ["type" .= ("integer" :: Text)]] + , "required" .= (["a"] :: [Text]) + ] + assertBool "present ok" (validateJSONSchema s (object ["a" .= (1 :: Int)])) + assertBool "missing not ok" (not $ validateJSONSchema s (object [])) + , testCase "patternProperties match" $ do + let s = + object + [ "type" .= ("object" :: Text) + , "patternProperties" .= object ["^x-" .= object ["type" .= ("string" :: Text)]] + ] + assertBool "x-foo ok" (validateJSONSchema s (object ["x-foo" .= ("bar" :: Text)])) + assertBool "x-foo wrong type" (not $ validateJSONSchema s (object ["x-foo" .= (1 :: Int)])) + , testCase "additionalProperties schema applies to extras" $ do + let s = + object + [ "type" .= ("object" :: Text) + , "properties" .= object ["a" .= object ["type" .= ("integer" :: Text)]] + , "additionalProperties" .= object ["type" .= ("string" :: Text)] + ] + assertBool "extra string ok" (validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= ("x" :: Text)])) + assertBool "extra int not ok" (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)])) + , testCase "unevaluatedProperties=false forbids extras not covered by props/patterns" $ do + let s = + object + [ "type" .= ("object" :: Text) + , "properties" .= object ["a" .= object []] + , "unevaluatedProperties" .= False + ] + assertBool "only a ok" (validateJSONSchema s (object ["a" .= (1 :: Int)])) + assertBool "extra b not ok" (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)])) + , testCase "local $ref into $defs resolves and validates" $ do + let s = + object + [ "$defs" .= object ["posInt" .= object ["type" .= ("integer" :: Text), "minimum" .= (0 :: Int)]] + , "type" .= ("object" :: Text) + , "properties" .= object ["age" .= object ["$ref" .= ("#/$defs/posInt" :: Text)]] + , "required" .= (["age"] :: [Text]) + ] + assertBool "age=5 ok" (validateJSONSchema s (object ["age" .= (5 :: Int)])) + assertBool "age=-1 not ok" (not $ validateJSONSchema s (object ["age" .= (-1 :: Int)])) + , testCase "unevaluatedItems with contains marks matches as evaluated; remainder must satisfy schema" $ do + let s = + object + [ "type" .= ("array" :: Text) + , "contains" .= object ["type" .= ("integer" :: Text)] + , "minContains" .= (1 :: Int) + , "unevaluatedItems" .= object ["type" .= ("string" :: Text)] + ] + assertBool "[1, \"x\", \"y\"] ok" (validateJSONSchema s (toJSON ([Number 1, String "x", String "y"] :: [Value]))) + assertBool + "[1, false] not ok (false not string)" + (not $ validateJSONSchema s (toJSON ([Number 1, Bool False] :: [Value]))) + , testCase "propertyNames constraint" $ do + let s = object ["type" .= ("object" :: Text), "propertyNames" .= object ["pattern" .= ("^[a-z]+$" :: Text)]] + assertBool "lowercase key ok" (validateJSONSchema s (object ["abc" .= (1 :: Int)])) + assertBool "uppercase key not ok" (not $ validateJSONSchema s (object ["Abc" .= (1 :: Int)])) + , testCase "min/max properties" $ do + let s = object ["type" .= ("object" :: Text), "minProperties" .= (1 :: Int), "maxProperties" .= (2 :: Int)] + assertBool "one ok" (validateJSONSchema s (object ["a" .= (1 :: Int)])) + assertBool "none not ok" (not $ validateJSONSchema s (object [])) + assertBool + "three not ok" + (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int), "c" .= (3 :: Int)])) + , -- dependentRequired / dependentSchemas + testCase "dependentRequired enforces required when key present" $ do + let s = + object + [ "type" .= ("object" :: Text) + , "dependentRequired" .= object ["credit_card" .= (["billing_address"] :: [Text])] + ] + assertBool "missing credit_card ok" (validateJSONSchema s (object ["name" .= ("Bob" :: Text)])) + assertBool "present without dependency not ok" (not $ validateJSONSchema s (object ["credit_card" .= ("123" :: Text)])) + assertBool + "present with dependency ok" + (validateJSONSchema s (object ["credit_card" .= ("123" :: Text), "billing_address" .= ("A" :: Text)])) + , testCase "dependentSchemas applies object schema when key present" $ do + let dep = object ["properties" .= object ["a" .= object ["const" .= (1 :: Int)]], "required" .= (["a"] :: [Text])] + s = object ["type" .= ("object" :: Text), "dependentSchemas" .= object ["flag" .= dep]] + assertBool "no flag ok" (validateJSONSchema s (object ["a" .= (2 :: Int)])) + assertBool "flag requires a=1" (validateJSONSchema s (object ["flag" .= True, "a" .= (1 :: Int)])) + assertBool "flag with wrong a not ok" (not $ validateJSONSchema s (object ["flag" .= True, "a" .= (2 :: Int)])) + , -- combinators + testCase "anyOf passes if any schema matches" $ do + let s = object ["anyOf" .= ([object ["type" .= ("string" :: Text)], object ["type" .= ("integer" :: Text)]] :: [Value])] + assertBool "int ok" (validateJSONSchema s (Number 3)) + , testCase "oneOf exactly one" $ do + let s = object ["oneOf" .= ([object ["type" .= ("number" :: Text)], object ["minimum" .= (0 :: Int)]] :: [Value])] + -- number 3 matches both type=number and minimum=0; should fail + assertBool "matches both not ok" (not $ validateJSONSchema s (Number 3)) + , testCase "allOf accumulates constraints" $ do + let s = object ["allOf" .= ([object ["type" .= ("number" :: Text)], object ["maximum" .= (5 :: Int)]] :: [Value])] + assertBool "6 not ok" (not $ validateJSONSchema s (Number 6)) + , testCase "not inverts" $ do + let s = object ["not" .= object ["type" .= ("null" :: Text)]] + assertBool "null not ok" (not $ validateJSONSchema s Null) + , -- conditionals if/then/else + testCase "if/then/else branching" $ do + let s = + object + [ "if" .= object ["properties" .= object ["a" .= object ["const" .= True]]] + , "then" .= object ["required" .= (["b"] :: [Text])] + , "else" .= object ["required" .= (["c"] :: [Text])] + ] + assertBool "a=true requires b" (not $ validateJSONSchema s (object ["a" .= True])) + assertBool "a=false requires c" (not $ validateJSONSchema s (object ["a" .= False])) + , -- format and content keywords are annotations in 2020-12: do not assert by default + testCase "format does not assert by default" $ do + let s = object ["type" .= ("string" :: Text), "format" .= ("email" :: Text)] + assertBool "non-email still valid (annotation only)" (validateJSONSchema s (String "not-an-email")) + , testCase "content keywords are annotations only" $ do + let s = + object + [ "type" .= ("string" :: Text) + , "contentEncoding" .= ("base64" :: Text) + , "contentMediaType" .= ("image/png" :: Text) + ] + -- we do not auto-decode/validate: annotation only + assertBool "arbitrary string still valid" (validateJSONSchema s (String "@@not-base64@@")) + ] + +deriveWorks :: TestTree +deriveWorks = + testGroup + "Derive Works (Aeson JSON validates against derived schema)" + [ testCase "Person record encodes and validates" $ do + let schema = toJSONSchema (Proxy :: Proxy Person) + jPerson = toJSON (Person "Bob" 42) + assertBool "Person JSON should validate against derived schema" (validateJSONSchema schema jPerson) + assertBool "Person schema should reject missing fields" (not $ validateJSONSchema schema (object [])) + , testCase "Shape sum (non-record) constructors validate" $ do + let schema = toJSONSchema (Proxy :: Proxy Shape) + j1 = toJSON (Circle 1.5) + j2 = toJSON (Rectangle 2.3 4.5) + assertBool "Circle JSON should validate" (validateJSONSchema schema j1) + assertBool "Rectangle JSON should validate" (validateJSONSchema schema j2) + , testCase "Animal sum (record) constructors validate" $ do + let schema = toJSONSchema (Proxy :: Proxy Animal) + j1 = toJSON (Dog "Fido" 5) + j2 = toJSON (Cat "Whiskers") + assertBool "Dog JSON should validate" (validateJSONSchema schema j1) + assertBool "Cat JSON should validate" (validateJSONSchema schema j2) + assertBool + "Dog schema should reject missing required fields" + ( not $ + validateJSONSchema + schema + (object ["tag" .= ("Dog" :: Text)]) + ) + assertBool + "Dog schema should reject missing tag" + ( not $ + validateJSONSchema + schema + (object ["dogName" .= ("Fido" :: Text), "dogAge" .= (5 :: Int)]) + ) + , testCase "Triple non-record product flattens and validates" $ do + let schema = toJSONSchema (Proxy :: Proxy Triple) + jTriple = toJSON (Triple 1 "a" True) + assertBool "Triple JSON should validate" (validateJSONSchema schema jTriple) + -- The tuple length is pinned: a short array must be rejected. + assertBool + "short array rejected" + (not (validateJSONSchema schema (Array (fromList [Number 1, String "a"])))) + , testCase "Maybe and list instances validate via derived schema" $ do + let maybeSchema = toJSONSchema (Proxy :: Proxy (Maybe Int)) + listSchema = toJSONSchema (Proxy :: Proxy [Text]) + assertBool "Just Int validates" (validateJSONSchema maybeSchema (toJSON (Just (3 :: Int)))) + assertBool "Nothing validates" (validateJSONSchema maybeSchema Null) + assertBool "[Text] validates" (validateJSONSchema listSchema (toJSON (["x", "y"] :: [Text]))) + , testCase "Either schema enforces discriminator semantics" $ do + let schema = toJSONSchema (Proxy :: Proxy (Either Int Text)) + leftVal = toJSON (Left (3 :: Int) :: Either Int Text) + rightVal = toJSON (Right ("hi" :: Text) :: Either Int Text) + emptyObj = object [] + bothObj = + object + [ "Left" .= (1 :: Int) + , "Right" .= ("oops" :: Text) + ] + assertBool "Left JSON should validate" (validateJSONSchema schema leftVal) + assertBool "Right JSON should validate" (validateJSONSchema schema rightVal) + assertBool "Empty object should be rejected" (not $ validateJSONSchema schema emptyObj) + assertBool "Object with both constructors should be rejected" (not $ validateJSONSchema schema bothObj) + ] + +schemaRecursiveWorks :: TestTree +schemaRecursiveWorks = + testGroup + "ToJSONSchema Works (recursive type emits $ref)" + [ testCase "Derived schema uses $defs and $ref for recursion" $ do + let s = toJSONSchema (Proxy :: Proxy RTree) + -- Top-level must be an object with $defs (and ideally $ref) + case s of + Object km -> do + -- \$defs contains RTree definition, and its Node constructor contains $ref back + case km KM.!? "$defs" of + Just (Object defs) -> case defs KM.!? fromString "RTree" of + Just (Object rtreeDef) -> do + -- look for 'anyOf' containing Node/Leaf. In Node path, ensure children $ref + case rtreeDef KM.!? fromString "anyOf" of + Just (Array alts) -> do + -- At least one alternative should be the tagged Node object with contents array + let hasRefBack = + V.any + ( \v -> case v of + Object km2 -> case km2 KM.!? fromString "properties" of + Just (Object props) -> case props KM.!? fromString "contents" of + Just (Object cont) -> case cont KM.!? fromString "prefixItems" of + Just (Array pfi) -> + V.all + ( \piV -> case piV of + Object o -> case o KM.!? fromString "$ref" of + Just (String r) -> r == "#/$defs/RTree" + _ -> False + _ -> False + ) + pfi + _ -> False + _ -> False + _ -> False + _ -> False + ) + alts + assertBool "Node contents references back to RTree via $ref" hasRefBack + _ -> assertFailure "RTree def missing anyOf" + _ -> assertFailure "$defs.RTree missing" + _ -> assertFailure "$defs missing" + _ -> assertFailure "Top-level schema should be object" + , testCase "Recursive value validates against derived schema" $ do + let s = toJSONSchema (Proxy :: Proxy RTree) + j = toJSON (Node (Leaf 1) (Leaf 2)) + assertBool "recursive value should validate" (validateJSONSchema s j) + ] + +-- A document dogfooded by the generate-then-validate tests: a root object that +-- references a named, patterned $def and carries a required + an optional field. +sampleDoc :: SchemaDocument +sampleDoc = + SchemaDocument + { schemaDefs = [("Code", SString (Just "^[a-z]+$"))] + , schemaRoot = + SObject + [ Field "code" True (SRef "Code") + , Field "count" False SInteger + ] + APForbidden + } + +sampleSchema :: Value +sampleSchema = schemaDocumentToValue sampleDoc + +{- | Value-directed construction: render with 'schemaToValue' / +'schemaDocumentToValue' and dogfood the result through the validator. +-} +valueDirectedWorks :: TestTree +valueDirectedWorks = + testGroup + "Value-directed construction" + [ testGroup "Per-constructor rendering" perConstructorRendering + , testGroup "Generate-then-validate" generateThenValidate + , testGroup "Edge cases" valueDirectedEdgeCases + ] + +perConstructorRendering :: [TestTree] +perConstructorRendering = + [ testCase "SNull" $ schemaToValue SNull @?= object ["type" .= ("null" :: Text)] + , testCase "SBoolean" $ schemaToValue SBoolean @?= object ["type" .= ("boolean" :: Text)] + , testCase "SInteger" $ schemaToValue SInteger @?= object ["type" .= ("integer" :: Text)] + , testCase "SNumber" $ schemaToValue SNumber @?= object ["type" .= ("number" :: Text)] + , testCase "SString Nothing" $ + schemaToValue (SString Nothing) @?= object ["type" .= ("string" :: Text)] + , testCase "SString (Just pattern)" $ + schemaToValue (SString (Just "^[a-z]+$")) + @?= object ["type" .= ("string" :: Text), "pattern" .= ("^[a-z]+$" :: Text)] + , testCase "SConst" $ + schemaToValue (SConst (String "x")) @?= object ["const" .= ("x" :: Text)] + , testCase "SEnum" $ + schemaToValue (SEnum [Number 1, Number 2]) @?= object ["enum" .= [Number 1, Number 2]] + , testCase "SArray" $ + schemaToValue (SArray SInteger) + @?= object ["type" .= ("array" :: Text), "items" .= integerSchema] + , testCase "SArrayUnique" $ + schemaToValue (SArrayUnique SInteger) + @?= object + [ "type" .= ("array" :: Text) + , "items" .= integerSchema + , "uniqueItems" .= True + ] + , testCase "STuple pins length with minItems/maxItems" $ + schemaToValue (STuple [SInteger, SString Nothing]) + @?= object + [ "type" .= ("array" :: Text) + , "prefixItems" .= [integerSchema, object ["type" .= ("string" :: Text)]] + , "items" .= False + , "minItems" .= (2 :: Int) + , "maxItems" .= (2 :: Int) + ] + , testCase "SObject omits required when none required" $ + schemaToValue (SObject [Field "x" False SInteger] APForbidden) + @?= object + [ "type" .= ("object" :: Text) + , "properties" .= object ["x" .= integerSchema] + , "additionalProperties" .= False + ] + , testCase "SObject lists required fields" $ + schemaToValue (SObject [Field "x" True SInteger] APForbidden) + @?= object + [ "type" .= ("object" :: Text) + , "properties" .= object ["x" .= integerSchema] + , "additionalProperties" .= False + , "required" .= (["x"] :: [Text]) + ] + , testCase "SObject APAllowed" $ + schemaToValue (SObject [] APAllowed) + @?= object + [ "type" .= ("object" :: Text) + , "properties" .= object [] + , "additionalProperties" .= True + ] + , testCase "SObject APSchema (open map)" $ + schemaToValue (SObject [] (APSchema SInteger)) + @?= object + [ "type" .= ("object" :: Text) + , "properties" .= object [] + , "additionalProperties" .= integerSchema + ] + , testCase "SNullable" $ + schemaToValue (SNullable SInteger) + @?= object ["anyOf" .= [integerSchema, object ["type" .= ("null" :: Text)]]] + , testCase "SAnyOf" $ + schemaToValue (SAnyOf [SInteger, SBoolean]) + @?= object ["anyOf" .= [integerSchema, object ["type" .= ("boolean" :: Text)]]] + , testCase "SAllOf" $ + schemaToValue (SAllOf [SInteger]) @?= object ["allOf" .= [integerSchema]] + , testCase "SRef simple name" $ + schemaToValue (SRef "Foo") @?= object ["$ref" .= ("#/$defs/Foo" :: Text)] + , testCase "SRef escapes JSON Pointer characters" $ + schemaToValue (SRef "a/b~c") @?= object ["$ref" .= ("#/$defs/a~1b~0c" :: Text)] + , testCase "SAny" $ schemaToValue SAny @?= object [] + , testCase "SRaw renders the Value verbatim" $ + schemaToValue (SRaw (object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)])) + @?= object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)] + ] + where + integerSchema = object ["type" .= ("integer" :: Text)] + +generateThenValidate :: [TestTree] +generateThenValidate = + [ testCase "conforming instance validates" $ + assertBool "should be valid" $ + validateJSONSchema sampleSchema (object ["code" .= ("abc" :: Text), "count" .= (3 :: Int)]) + , testCase "optional field may be omitted" $ + assertBool "should be valid" $ + validateJSONSchema sampleSchema (object ["code" .= ("abc" :: Text)]) + , testCase "missing required field rejected" $ + assertBool "should be invalid" $ + not (validateJSONSchema sampleSchema (object ["count" .= (3 :: Int)])) + , testCase "wrong type rejected" $ + assertBool "should be invalid" $ + not (validateJSONSchema sampleSchema (object ["code" .= (1 :: Int)])) + , testCase "extra field rejected under additionalProperties:false" $ + assertBool "should be invalid" $ + not (validateJSONSchema sampleSchema (object ["code" .= ("abc" :: Text), "extra" .= True])) + , testCase "off-pattern string rejected" $ + assertBool "should be invalid" $ + not (validateJSONSchema sampleSchema (object ["code" .= ("ABC" :: Text)])) + , testCase "root-is-$ref document resolves" $ do + let doc = SchemaDocument [("Code", SString (Just "^[a-z]+$"))] (SRef "Code") + v = schemaDocumentToValue doc + assertBool "conforming valid" (validateJSONSchema v (String "abc")) + assertBool "off-pattern invalid" (not (validateJSONSchema v (String "ABC"))) + ] + +valueDirectedEdgeCases :: [TestTree] +valueDirectedEdgeCases = + [ testCase "SAnyOf [] rejects everything" $ + assertBool "should be invalid" $ + not (validateJSONSchema (schemaToValue (SAnyOf [])) (Number 1)) + , testCase "SAllOf [] accepts everything" $ + assertBool "should be valid" $ + validateJSONSchema (schemaToValue (SAllOf [])) (Number 1) + , testCase "SEnum [] rejects everything" $ + assertBool "should be invalid" $ + not (validateJSONSchema (schemaToValue (SEnum [])) (Number 1)) + , testCase "STuple rejects short and long arrays" $ do + let s = schemaToValue (STuple [SInteger, SString Nothing]) + assertBool "empty invalid" (not (validateJSONSchema s (Array (fromList [])))) + assertBool "short invalid" (not (validateJSONSchema s (Array (fromList [Number 1])))) + assertBool "exact valid" (validateJSONSchema s (Array (fromList [Number 1, String "x"]))) + assertBool "long invalid" (not (validateJSONSchema s (Array (fromList [Number 1, String "x", Bool True])))) + , testCase "SObject APSchema validates open-map values" $ do + let s = schemaToValue (SObject [] (APSchema SInteger)) + assertBool "homogeneous ints valid" (validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)])) + assertBool "wrong value type invalid" (not (validateJSONSchema s (object ["a" .= ("x" :: Text)]))) + , testCase "SConst carrying a non-primitive Value" $ do + let s = schemaToValue (SConst (object ["k" .= (1 :: Int)])) + assertBool "structural match valid" (validateJSONSchema s (object ["k" .= (1 :: Int)])) + assertBool "different object invalid" (not (validateJSONSchema s (object ["k" .= (2 :: Int)]))) + , testCase "SRef with escaped $defs name resolves" $ do + let doc = SchemaDocument [("a/b~c", SInteger)] (SRef "a/b~c") + v = schemaDocumentToValue doc + assertBool "integer valid" (validateJSONSchema v (Number 1)) + assertBool "string invalid" (not (validateJSONSchema v (String "x"))) + , testCase "SRaw embeds an out-of-subset keyword inside a Schema" $ do + -- minLength is not in the Schema vocabulary; SRaw splices it into a field. + let s = + schemaToValue + ( SObject + [Field "name" True (SRaw (object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)]))] + APForbidden + ) + assertBool "long enough valid" (validateJSONSchema s (object ["name" .= ("abcd" :: Text)])) + assertBool "too short invalid" (not (validateJSONSchema s (object ["name" .= ("ab" :: Text)]))) + , testCase "SchemaDocument merges the header into an SRaw object root" $ do + let v = schemaDocumentToValue (SchemaDocument [] (SRaw (object ["type" .= ("string" :: Text)]))) + case v of + Object km -> do + assertBool "$schema present" (KM.member "$schema" km) + assertBool "root keys preserved" (KM.lookup "type" km == Just (String "string")) + _ -> assertFailure "expected an object document" + , testCase "SchemaDocument wraps a non-object SRaw root under allOf" $ do + let v = schemaDocumentToValue (SchemaDocument [("X", SInteger)] (SRaw (Bool True))) + case v of + Object km -> do + assertBool "$schema present" (KM.member "$schema" km) + assertBool "$defs present" (KM.member "$defs" km) + assertBool "allOf wrapper present" (KM.member "allOf" km) + _ -> assertFailure "expected an object document" + assertBool "allOf:[true] accepts anything" (validateJSONSchema v (Number 5)) + , testCase "SchemaDocument $defs win over an SRaw root's own $defs" $ do + let rootWithDefs = SRaw (object ["$defs" .= object ["Y" .= object ["type" .= ("boolean" :: Text)]]]) + v = schemaDocumentToValue (SchemaDocument [("X", SInteger)] rootWithDefs) + case v of + Object km -> case KM.lookup "$defs" km of + Just (Object defsKm) -> do + assertBool "document def X kept" (KM.member "X" defsKm) + assertBool "root def Y dropped" (not (KM.member "Y" defsKm)) + _ -> assertFailure "expected a $defs object" + _ -> assertFailure "expected an object document" ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -8,7 +8,7 @@ tests :: TestTree tests = - testGroup - "JSONSchema Tests" - [ JSONSchema.tests - ] + testGroup + "JSONSchema Tests" + [ JSONSchema.tests + ]