jsonschema (empty) → 0.2.0.0
raw patch · 9 files changed
+2410/−0 lines, 9 filesdep +aesondep +basedep +containers
Dependencies added: aeson, base, containers, jsonschema, regex-tdfa, scientific, tasty, tasty-hunit, text, vector
Files
- CHANGELOG.md +10/−0
- LICENSE +373/−0
- README.md +166/−0
- jsonschema.cabal +70/−0
- src/Data/JSON/JSONSchema.hs +44/−0
- src/Data/JSON/ToJSONSchema.hs +452/−0
- src/JSONSchema/Validation.hs +791/−0
- test/JSONSchema/Spec.hs +490/−0
- test/Main.hs +14/−0
+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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: <payload> }`.+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.
+ jsonschema.cabal view
@@ -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
+ src/Data/JSON/JSONSchema.hs view
@@ -0,0 +1,44 @@+-- |+-- Module: Data.JSON.JSONSchema+-- Copyright: (c) DPella AB 2025+-- License: LicenseRef-AllRightsReserved+-- Maintainer: <matti@dpella.io>, <lobo@dpella.io>+--+-- 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
+ src/Data/JSON/ToJSONSchema.hs view
@@ -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: <matti@dpella.io>, <lobo@dpella.io>+--+-- 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/<root>"} 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))+ ]+ ]
+ src/JSONSchema/Validation.hs view
@@ -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: <matti@dpella.io>, <lobo@dpella.io>+--+-- 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+ _ -> []
+ test/JSONSchema/Spec.hs view
@@ -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)+ ]
+ test/Main.hs view
@@ -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+ ]