diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Changelog + +## 0.2.0 +- Move the public API to `Data.JSON.JSONSchema` and supporting machinery to `Data.JSON.ToJSONSchema`. +- Tighten derived record/sum schemas to emit `required` arrays and discriminator requirements. +- Fix numeric validation to operate on exact `Scientific` values. +- Add regression coverage for large integers and high-precision decimals. + +## 0.1.0 +- Initial release with JSON Schema 2020-12 generation and validation support. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,166 @@ +# jsonschema + +Haskell library for deriving and validating JSON Schema (2020-12). + +This library provides: + +- Automatic JSON Schema derivation from Haskell types via `GHC.Generics`. +- Sensible encodings for records, products, and sum types (with tags). +- `$defs`/`$ref` support for recursive types. +- A validator that implements the core 2020-12 validation + applicator vocabularies. +- Helpful error reporting with instance paths when you want detailed feedback. +- High-level API exposed through `Data.JSON.JSONSchema` (re-exporting `ToJSONSchema` and helpers). + + +## 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`. +- 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). +- Recursive types are emitted under `"$defs"` and referenced with `"$ref"`. +- Validation covers: `type`, `const`, `enum`, numeric and string constraints, arrays (`prefixItems`, `items`, `contains`, `minContains`, `maxContains`), objects (`properties`, `patternProperties`, `additionalProperties`, `propertyNames`, `required`, `dependentSchemas`, `dependentRequired`), combinators (`anyOf`, `oneOf`, `allOf`, `not`), conditionals (`if`/`then`/`else`), and pragmatic `unevaluated*`. +- Local `$ref` resolution using JSON Pointers within the same document. + +Notes and limits: + +- JSON Schema version: 2020-12. `format` and `content*` are treated as annotations (not asserted). +- `$ref` resolution is local (`#...`) only; external URIs/anchors are not resolved. +- `unevaluatedProperties`/`unevaluatedItems` are implemented with a practical, local approximation. + + +## Quick Start + +Add the library to your build, then import the high-level module: + +```haskell +import GHC.Generics (Generic) +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) +``` + +### 1) Derive a schema for your type + +```haskell +data Person = Person + { name :: Text + , age :: Int + } deriving (Show, Eq, Generic) + +instance ToJSON Person +instance ToJSONSchema Person + +-- Produce the JSON Schema (as an Aeson Value) +personSchema :: Value +personSchema = toJSONSchema (Proxy :: Proxy Person) +``` + +What you get (shape, simplified): + +```jsonc +{ + "$defs": { + "Person": { + "type": "object", + "properties": { + "name": {"type": "string"}, + "age": {"type": "integer"} + }, + "additionalProperties": false, + "required": ["name", "age"] + } + }, + "$ref": "#/$defs/Person" +} +``` + +Sum types are tagged. For example: + +```haskell +data Shape + = Circle Double + | Rectangle Double Double + deriving (Show, Eq, Generic) + +instance ToJSON Shape +instance ToJSONSchema Shape + +shapeSchema :: Value +shapeSchema = toJSONSchema (Proxy :: Proxy Shape) +``` + +Non-record constructors encode as objects like `{ tag: { const: "Circle" }, contents: }`. +Record constructors encode as objects with a `tag` plus their named fields. + + +### 2) Validate data against a schema + +Use the simple boolean check: + +```haskell +import Data.Aeson (toJSON) + +valid :: Bool +valid = validateJSONSchema personSchema (toJSON (Person "Alice" 30)) +``` + +Or collect all validation errors: + +```haskell +import JSONSchema.Validation (validate, validateWithErrors, ValidationError(..)) + +case validate personSchema (toJSON (Person "Alice" 30)) of + Right () -> putStrLn "OK" + Left errs -> mapM_ print errs -- includes JSON Pointer-like paths +``` + +You can validate any `Value` against any schema, including hand-written schemas: + +```haskell +let schema = object + [ "type" .= ("object" :: Text) + , "properties" .= object ["name" .= object ["type" .= ("string" :: Text)]] + , "required" .= (["name"] :: [Text]) + ] +in validateJSONSchema schema (object ["name" .= ("Bob" :: Text)]) +``` + + +### 3) Custom schemas for special types + +Provide an explicit instance when you need a specific schema shape: + +```haskell +newtype UUID = UUID Text + +instance ToJSONSchema UUID where + toJSONSchema _ = object + [ "type" .= ("string" :: Text) + , "minLength" .= (36 :: Int) + , "maxLength" .= (36 :: Int) + ] +``` + + +## Tips + +- Pretty-print schemas with `aeson-pretty` if you want human-friendly output. +- For `Maybe a`, the schema is `anyOf [schema(a), {"type":"null"}]`. +- For `[a]`, the schema is `{ "type": "array", "items": schema(a) }`. +- For `Either a b`, the schema is `anyOf` with `{ "Left": a }` and `{ "Right": b }` object encodings. + + +## Development + +- Build and test with Cabal: + - `cabal build` + - `cabal test` + + +## License + +Released under the Mozilla Public License 2.0 by DPella AB. See `LICENSE` for details. diff --git a/jsonschema.cabal b/jsonschema.cabal new file mode 100644 --- /dev/null +++ b/jsonschema.cabal @@ -0,0 +1,70 @@ +cabal-version: 2.2 +name: jsonschema +version: 0.2.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. + The library includes a generic deriving strategy that handles recursive data types, + 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 + +library + default-language: + Haskell2010 + default-extensions: + DataKinds + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , OverloadedStrings + , PolyKinds + , RankNTypes + , TypeApplications + hs-source-dirs: + src + exposed-modules: + Data.JSON.JSONSchema + other-modules: + Data.JSON.ToJSONSchema + JSONSchema.Validation + build-depends: + base >=4.18 && <4.19 + , text >= 2.0 && <2.1 + , aeson >= 2.2 && <2.3 + , containers >= 0.6.7 && <0.6.8 + , vector >=0.13 && < 0.14 + , scientific >= 0.3.8 && <0.3.9 + , regex-tdfa >= 1.3.2 && <1.3.3 + + +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.19 + , jsonschema + , aeson + , text + , vector + , tasty + , tasty-hunit diff --git a/src/Data/JSON/JSONSchema.hs b/src/Data/JSON/JSONSchema.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/JSONSchema.hs @@ -0,0 +1,44 @@ +-- | +-- 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, +) where + +import Data.Proxy +import Data.JSON.ToJSONSchema +import JSONSchema.Validation diff --git a/src/Data/JSON/ToJSONSchema.hs b/src/Data/JSON/ToJSONSchema.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/ToJSONSchema.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# 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 ( + ToJSONSchema (..), + Proxy (..), +) where + +import Data.Aeson +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (isJust) +import Data.Proxy +import Data.String (IsString (..)) +import Data.Text (Text, pack) +import Data.Typeable +import Data.Vector qualified as V +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. +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)) + +-- | 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)] + +-- | Text instance. +instance ToJSONSchema Text where + toJSONSchema _ = object ["type" .= ("string" :: Text)] + +-- | Boolean schema instance. +instance ToJSONSchema Bool where + toJSONSchema _ = object ["type" .= ("boolean" :: Text)] + +-- | Machine integer schema instance. +instance ToJSONSchema Int where + toJSONSchema _ = object ["type" .= ("integer" :: Text)] + +-- | Arbitrary precision integer schema instance. +instance ToJSONSchema Integer where + toJSONSchema _ = object ["type" .= ("integer" :: Text)] + +-- | Single precision floating point schema instance. +instance ToJSONSchema Float where + toJSONSchema _ = object ["type" .= ("number" :: Text)] + +-- | Double precision floating point schema instance. +instance ToJSONSchema Double where + 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) + ] + +-- | 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 + ] + ] + ] + +-- | 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)] + ] + ] + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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]] + +-- | 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 (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 + ] + +-- | 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 + ) +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 (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 + +-- | 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) + +-- | 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 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] + , "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)) + +-- | 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)) + ] + ] diff --git a/src/JSONSchema/Validation.hs b/src/JSONSchema/Validation.hs new file mode 100644 --- /dev/null +++ b/src/JSONSchema/Validation.hs @@ -0,0 +1,791 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# 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 + _ -> [] diff --git a/test/JSONSchema/Spec.hs b/test/JSONSchema/Spec.hs new file mode 100644 --- /dev/null +++ b/test/JSONSchema/Spec.hs @@ -0,0 +1,490 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module JSONSchema.Spec (tests) where + +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) + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import qualified JSONSchema.Spec as JSONSchema +import Test.Tasty + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "JSONSchema Tests" + [ JSONSchema.tests + ]