jsons-to-schema (empty) → 0.1.0.0
raw patch · 20 files changed
+2198/−0 lines, 20 filesdep +Globdep +QuickCheckdep +aesonsetup-changed
Dependencies added: Glob, QuickCheck, aeson, aeson-pretty, base, bytestring, conduit, conduit-combinators, containers, hjsonschema, hspec, jsons-to-schema, neat-interpolation, optparse-applicative, protolude, quickcheck-instances, safe, scientific, semigroups, text, uniplate, unordered-containers, vector
Files
- LICENSE +7/−0
- README.md +44/−0
- Setup.hs +2/−0
- app/Main.hs +104/−0
- jsons-to-schema.cabal +101/−0
- src/JSONSchema/Draft4/Internal/Utils.hs +121/−0
- src/JSONSchema/Draft4/SchemaGeneration.hs +150/−0
- src/JSONSchema/Draft4/SchemaGenerationConfig.hs +62/−0
- src/JSONSchema/Draft4/SchemaUnification.hs +166/−0
- test/JSONSchema/Draft4/ArrayTypeTests.hs +314/−0
- test/JSONSchema/Draft4/BasicTypeTests.hs +95/−0
- test/JSONSchema/Draft4/ComplexTypeTests.hs +259/−0
- test/JSONSchema/Draft4/QuickCheckInstances.hs +236/−0
- test/JSONSchema/Draft4/QuickCheckTests.hs +134/−0
- test/JSONSchema/Draft4/SchemaConverterSpec.hs +63/−0
- test/JSONSchema/Draft4/UnifiersSpec.hs +72/−0
- test/Main.hs +13/−0
- test/Spec.hs +1/−0
- test/TestUtils.hs +125/−0
- test/UtilsSpec.hs +129/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright 2017 Gareth Tan++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,44 @@+# JSONs to Schema++**A JSON Schema Draft 4 Generator from JSON Instances**++Suppose you have an API that produces complex and somewhat varied JSON. You'd like to be able to document that API in a standard format by observing only its output. [JSON Schema](http://json-schema.org/) is a reasonable format for that. But simply generating the schema for one document will lead to an incomplete description of the API since not all documents will have all the keys in the full document. This is where this library comes in.++## CLI Overview++JSONs to Schema can also be used on the command line. After locating the installed binary, run it with `--help` to get detailed usage instructions.++## API Overview++The main API function is `jsonsToSchema` along with its configuration-taking equivalent, `jsonsToSchemaWithConfig`. This will transform a set of JSON documents into a single `Maybe` schema. ++Other helpful functions are `jsonToSchema`, which transforms a single document, and `schemasToSchema`, which performs the actual work of schema unification. ++## Properties++The schema generator should satisfy these properties:++- An schema generated from a JSON document will always be able to validate that JSON document.+- When a schema is merged with another schema, all objects that would validate under either schema, subject to the assumptions below, will validate under the merged schema regardless of merge order.++Unlike other generators strictness is meant to be customizable. Whether to allow additional properties in schema objects is something that the user can turn on and off.++### Assumptions+When merging JSON documents the generator keeps track of only one possible underlying type for each primitive type. Thus, if there were two documents `{"name": "x"}` and `{"cost": 24}` they will be assumed to represent two different manifestations of a single document that has both the `name` and the `cost` keys, rather than two different documents.++If given an object and an array (or some other primitive type), however, the generator will be able to assume that the particular JSON document can be either an object or an array type. ++## Prior Art++This project was inspired by [GenSON](https://github.com/wolverdude/GenSON), a Python project that does much of the same, but aims to be more customizable, correct, and powerful. ++Certain features were also inspired by [schema-guru](https://github.com/snowplow/schema-guru), but this project aims to be more customizable and have a programmatic API. Schema Guru's enum and range detection features are planned to be matched by this library. ++## Future Plans+- Option to autogenerate enumerations for fields with below a certain limit of values+- Option to automatically detect ranges for integers, strings, arrays, and objects+++## Not Planned+- Recognition of known JSON Schema formats (UUIDs and IP addresses, for example)+- Support for JSON or JSON Schema extensions
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Conduit ((.|))+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import qualified GHC.Base++import Protolude++import qualified Data.List as L+import Options.Applicative hiding ((<>))+import qualified System.FilePath.Glob as G++import qualified JSONSchema.Draft4.Internal.Utils as Utils+import JSONSchema.Draft4.SchemaGeneration (jsonToSchemaWithConfig,+ unifySchemas)+import qualified JSONSchema.Draft4.SchemaGenerationConfig as SGC++data Input = FileInput [FilePath]+ | StandardInput+ deriving (Show)++data Options = Options {+ input :: Input+ , generationConfig :: SGC.SchemaGenerationConfig+} deriving (Show)++version :: Parser (a -> a)+version = infoOption "JSON to Schema 0.1.0"+ ( long "version"+ <> short 'v'+ <> help "Prints version information." )++configParser :: Parser SGC.SchemaGenerationConfig+configParser = SGC.SchemaGenerationConfig+ <$> switch+ ( long "type-arrays-as-tuples"+ <> help "When disabled (default), all objects in an array are assumed to have the \+ \ same type and are unified accordingly. When enabled, arrays are considered to\+ \ be tuples and each index will have its own type. For example, [14, false]\+ \ is either an array that can take integer or boolean objects (disabled) or a tuple \+ \ that is an integer in its first index and a boolean in its second.")+ <*> switch+ ( long "seal-object-properties"+ <> help "Toggles additionalProperties for each object instance in the JSON schema. \+ \ When disabled (default), a JSON object instance that has more\+ \ properties than specified in the schema will continue to validate. \+ \ When enabled, a JSON object instance that has more properties \+ \ than specified will no longer validate.")++fileInputParser :: Parser Input+fileInputParser = FileInput+ <$> some (strOption+ (long "path"+ <> short 'p'+ <> metavar "TARGET"+ <> help "Can be specified multiple times. Each path can be a glob.\+ \ All files matching these paths will be read and their JSONs \+ \ will be combined."))++standardInputParser :: Parser Input+standardInputParser = flag' StandardInput+ ( long "stdin"+ <> help "Reads JSON from stdin instead of a path, e.g. cat file.json | jsons-to-schema --stdin")++parser :: Parser Options+parser = Options+ <$> (fileInputParser <|> standardInputParser)+ <*> configParser++pInfo :: ParserInfo Options+pInfo = info+ (parser <**> helper <**> version)+ ( fullDesc+ <> progDesc "A JSON Schema Draft 4 Generator from JSON instances."+ <> header "JSON to Schema")++globPaths :: [GHC.Base.String] -> IO [FilePath]+globPaths ss = (L.concat . fst) <$> G.globDir patterns ""+ where+ patterns = fmap G.compile ss++getSource (FileInput fps) = do+ paths <- globPaths fps+ putText $ fromMaybe (panic "Could not find any files matching any of the globs provided")+ (if null paths then Nothing else Just "")+ return $ mapM_ CC.sourceFile paths+getSource StandardInput = return $ mapM_ CC.sourceHandle [stdin]++main :: IO ()+main = do+ options <- execParser pInfo+ let c = generationConfig options++ conduitSource <- getSource (input options)+ schema <- C.runConduitRes+ $ conduitSource+ .| CC.map (jsonToSchemaWithConfig c . Utils.parseValue)+ .| CC.foldl1 unifySchemas++ putText $ Utils.printSchema (fromMaybe (panic "Error unifying schemas.") schema)
+ jsons-to-schema.cabal view
@@ -0,0 +1,101 @@+name: jsons-to-schema+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE+copyright: 2017 Gareth Tan+maintainer: Gareth Tan+homepage: https://github.com/garetht/jsons-to-schema/README.md+synopsis: JSON to JSON Schema+description:+ A JSON Schema Draft 4 Generator from JSON Instances+category: Data, Web, JSON+author: Gareth Tan+tested-with: GHC == 7.10.3, GHC == 8.0.2+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/garetht/jsons-to-schema++library+ exposed-modules:+ JSONSchema.Draft4.SchemaGeneration+ JSONSchema.Draft4.SchemaGenerationConfig+ JSONSchema.Draft4.Internal.Utils+ build-depends:+ base >=4.7 && <5,+ hjsonschema >=1.6.3 && <1.7,+ text >=1.2.2.2 && <1.3,+ bytestring >=0.10.6.0 && <0.11,+ semigroups >=0.18.2 && <0.19,+ aeson >=0.11.3.0 && <1.2,+ protolude >=0.1.10 && <0.2,+ aeson-pretty >=0.7.2 && <0.9,+ unordered-containers >=0.2.8.0 && <0.3,+ containers >=0.5.6.2 && <0.6,+ vector >=0.11.0.0 && <0.13,+ safe >=0.3.14 && <0.4,+ scientific >=0.3.4.9 && <0.4,+ QuickCheck >=2.8.2 && <2.10+ default-language: Haskell2010+ default-extensions: OverloadedStrings NoImplicitPrelude+ hs-source-dirs: src+ other-modules:+ JSONSchema.Draft4.SchemaUnification+ ghc-options: -fwarn-missing-signatures -fwarn-incomplete-patterns -fwarn-unused-imports -fwarn-unused-binds -fwarn-name-shadowing++executable jsons-to-schema-exe+ main-is: Main.hs+ build-depends:+ base >=4.7 && <5,+ jsons-to-schema,+ protolude >=0.1.10 && <0.2,+ optparse-applicative >=0.12.1.0 && <0.14,+ Glob >=0.7.14 && <0.9,+ conduit >=1.2.10 && <1.3,+ conduit-combinators >=1.0.8.3 && <1.2,+ bytestring >=0.10.6.0 && <0.11,+ hjsonschema >=1.6.3 && <1.7+ default-language: Haskell2010+ hs-source-dirs: app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-incomplete-patterns -fwarn-unused-imports -fwarn-unused-binds -fwarn-name-shadowing++test-suite jsons-to-schema-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends:+ base >=4.7 && <5,+ jsons-to-schema,+ hspec >=2.2.4 && <2.5,+ scientific >=0.3.4.9 && <0.4,+ protolude >=0.1.10 && <0.2,+ neat-interpolation >=0.3.2.1 && <0.4,+ hjsonschema >=1.6.3 && <1.7,+ text >=1.2.2.2 && <1.3,+ bytestring >=0.10.6.0 && <0.11,+ aeson >=0.11.3.0 && <1.2,+ aeson-pretty >=0.7.2 && <0.9,+ QuickCheck >=2.8.2 && <2.10,+ quickcheck-instances >=0.3.12 && <0.4,+ containers >=0.5.6.2 && <0.6,+ unordered-containers >=0.2.8.0 && <0.3,+ uniplate >=1.6.12 && <1.7,+ vector >=0.11.0.0 && <0.13+ default-language: Haskell2010+ default-extensions: OverloadedStrings NoImplicitPrelude+ hs-source-dirs: test+ other-modules:+ JSONSchema.Draft4.SchemaConverterSpec+ JSONSchema.Draft4.BasicTypeTests+ JSONSchema.Draft4.ArrayTypeTests+ JSONSchema.Draft4.ComplexTypeTests+ JSONSchema.Draft4.QuickCheckTests+ JSONSchema.Draft4.QuickCheckInstances+ JSONSchema.Draft4.UnifiersSpec+ TestUtils+ UtilsSpec+ Spec+ ghc-options: -fwarn-missing-signatures -fwarn-incomplete-patterns -fwarn-unused-imports -fwarn-unused-binds -fwarn-name-shadowing -threaded -rtsopts -with-rtsopts=-N
+ src/JSONSchema/Draft4/Internal/Utils.hs view
@@ -0,0 +1,121 @@+{-|+ Module : JSONSchema.Draft4.Internal.Utils+ Description : Internal utilities.+ Copyright : (c) Gareth Tan, 2017+ License : MIT++ Assorted internal utilities.+-}++module JSONSchema.Draft4.Internal.Utils+ (+ alt+ , andMaybe+ , computeMaximumConstraints+ , computeMinimumConstraints+ , zipWithPadding+ , listToMaybeList+ , setToMaybeSet+ , parseValue+ , printSchema+ ) where++import Protolude++import qualified Data.Aeson as AE+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Scientific as DS+import qualified Data.Set as DS+import qualified Data.Text.Encoding as TE+import qualified Data.Aeson.Encode.Pretty as AEEP+import qualified JSONSchema.Draft4 as D4+++-- |Functions like an Applicative but keeps the 'Just' value if it exists.+alt :: Alternative f => (a -> a -> a) -> f a -> f a -> f a+alt f a b = f <$> a <*> b <|> a <|> b++-- |Make certain functions return Nothing when handed an empty list instead+-- of carrying on with their current behavior+emptyFold :: (Foldable t) => (t a -> a) -> t a -> Maybe a+emptyFold f tma+ | null tma = Nothing+ | otherwise = Just $ f tma++-- |Returns the and of the Just values or Nothing if there are no Justs+andMaybe :: [Maybe Bool] -> Maybe Bool+andMaybe = emptyFold and . catMaybes++{-| The unification function for the integer constraints @maximum@ and @exclusiveMaximum@.+ When unifying schemas the @exclusiveMaximum@ may somestimes need to be modified+ based on the @maximum.+-}+computeMaximumConstraints ::+ [Maybe DS.Scientific] -> [Maybe Bool] -> (Maybe DS.Scientific, Maybe Bool)+computeMaximumConstraints maxes emaxes =+ maximumBy zipComparer (zip maxes emaxes)+ -- We use Down to reverse the compare order so that False > True+ -- We need False > True because if two schemas have the same maximum+ -- but one excludes the maximum then we want the schema to not exclude the+ -- maximum (i.e. it is more inclusive)+ where+ zipComparer (m1, em1) (m2, em2) =+ if m1 == m2+ then if and $ isNothing <$> [m1, m2] then compare em1 em2 else compare (Down em1) (Down em2)+ else compare m1 m2++-- Usually the ordering goes like this: Nothing < Just 20 < Just 30, and so the+-- minimum is Nothing. But we want the ordering to be Just 20 < Just 30 < Nothing+-- (Down would provide the ordering Just 30 < Just 20 < Nothing), so we provide+-- a custom comparison function+{-| The unification function for the integer constraints @minimum@ and @exclusiveMinimum@.+ When unifying schemas the @exclusiveMinimum@ may somestimes need to be modified+ based on the @minimum.+-}+computeMinimumConstraints ::+ [Maybe DS.Scientific] -> [Maybe Bool] -> (Maybe DS.Scientific, Maybe Bool)+computeMinimumConstraints mins emins = minimumBy zipComparer (zip mins emins)+ where+ justComparer :: (Ord a) => Maybe a -> Maybe a -> Ordering+ justComparer (Just x) (Just y) = compare x y+ justComparer (Just _) Nothing = LT+ justComparer Nothing (Just _) = GT+ justComparer Nothing Nothing = EQ+ zipComparer (m1, em1) (m2, em2)+ =+ if m1 == m2+ then if and $ isNothing <$> [m1, m2] then compare (Down em1) (Down em2) else compare em1 em2+ else justComparer m1 m2++-- This function is from StackOverflow+-- | Zips a list but uses the default value if one list is longer than the other.+zipWithPadding :: a -> b -> [a] -> [b] -> [(a, b)]+zipWithPadding a b (x:xs) (y:ys) = (x, y) : zipWithPadding a b xs ys+zipWithPadding a _ [] ys = zip (repeat a) ys+zipWithPadding _ b xs [] = zip xs (repeat b)++{-| Similar to 'listFromMaybe', but returns the entire list as a+ 'Just' if it is not empty instead of only the first item. -}+listToMaybeList :: [a] -> Maybe [a]+listToMaybeList [] = Nothing+listToMaybeList xs = Just xs++{-| Returns the entire set as a 'Just' if it is not empty+ instead of only one item. -}+setToMaybeSet :: DS.Set a -> Maybe (DS.Set a)+setToMaybeSet s+ | DS.null s = Nothing+ | otherwise = Just s+++{-| Parses a bytestring to a value. -}+parseValue :: BS.ByteString -> AE.Value+parseValue s =+ fromMaybe (panic $ "Failed to parse JSON document " <> TE.decodeUtf8 s) .+ AE.decode .+ BSL.fromStrict $ s++{-| Converts a schema to text. -}+printSchema :: D4.Schema -> Text+printSchema = TE.decodeUtf8 . BSL.toStrict . AEEP.encodePretty . AE.toJSON
+ src/JSONSchema/Draft4/SchemaGeneration.hs view
@@ -0,0 +1,150 @@+{-|+ Module : JSONSchema.Draft4.SchemaGeneration+ Description : Generates schemas from JSON and other schemas+ Copyright : (c) Gareth Tan, 2017+ License : MIT++ Provides a set of utilities to combine JSON documents or JSON+ Schemas into a single schema.++ All JSON documents provided __must__be completely dereferenced. JSON+ references found as @$ref@ keys within the document will be treated+ as regular key-value pairs. No attempt will be made to determine+ where those references point to.++ In unfiying schemas we will only attempt the unification of the following :+ @maximum@, @exclusiveMaximum@, @minimum@, @exclusiveMinimum@,+ @maxLength@, @minLength@, @items@, @additionalItems@, @maxItems@,+ @minItems@, @uniqueItems@, @required@, @properties@, @additionalProperties@,+ @maxProperties@, @minProperties@, @patternProperties@ and @type@.++ Keys that are not in this list are subject to arbitrary overriding when+ unifying multiple schemas. For example, when unifying two schemas with+ differing versions, only one of them will be kept.+-}++module JSONSchema.Draft4.SchemaGeneration+ ( jsonToSchema+ , jsonToSchemaWithConfig+ , jsonsToSchema+ , jsonsToSchemaWithConfig+ , schemasToSchema+ , unifySchemas+ ) where++import Protolude++import JSONSchema.Draft4.SchemaUnification (unifySchemas)++import qualified Data.Aeson as AE+import qualified Data.HashMap.Lazy as HM+import qualified Data.Scientific as DSC+import qualified Data.Set as DST+import qualified Data.Vector as V+import qualified JSONSchema.Draft4 as D4++import qualified JSONSchema.Validator.Draft4.Any as V4A+import qualified JSONSchema.Validator.Draft4.Array as V4Arr+import qualified JSONSchema.Validator.Draft4.Object as V4Obj++import qualified Safe.Foldable as SF++import JSONSchema.Draft4.SchemaGenerationConfig+import qualified JSONSchema.Draft4.Internal.Utils as Utils+++makeBasicTypeSchema :: V4A.SchemaType -> D4.Schema+makeBasicTypeSchema t =+ D4.emptySchema {D4._schemaType = Just $ V4A.TypeValidatorString t}++makeObjectSchema :: SchemaGenerationConfig -> AE.Object -> D4.Schema+makeObjectSchema c o =+ (makeBasicTypeSchema V4A.SchemaObject) {+ D4._schemaRequired = requireds o+ , D4._schemaProperties = properties o+ , D4._schemaAdditionalProperties = additionalProperties+ }+ where+ -- We add the required property only if an object has keys. Generating+ -- required: [] will not work because the Draft 4 specification does not+ -- permit empty arrays. Instead, when unifying the required type, we+ -- make sure that a _schemaRequired of Nothing will eliminate all other+ -- specified required properties, i.e. if an object does not require any+ -- properties, than no other object can either.+ requireds = fmap DST.fromList . Utils.listToMaybeList . HM.keys+ properties :: HM.HashMap Text AE.Value -> Maybe (HM.HashMap Text D4.Schema)+ properties = Just . map (jsonToSchemaWithConfig c)+ -- Make objects unable to accept additional properties if specified by the user+ additionalProperties = if sealObjectProperties c+ then Just $ V4Obj.AdditionalPropertiesBool False+ else Nothing++makeArrayAsTupleSchema :: SchemaGenerationConfig -> AE.Array -> D4.Schema+makeArrayAsTupleSchema c xs =+ (makeBasicTypeSchema V4A.SchemaArray) {+ -- the inner Maybe checks to see if the array is empty+ -- because "items": [] is not valid according to the metaschema+ -- Under 5.3.1.4. Default values the absence of `items` is equivalent+ -- to "items": {}+ D4._schemaItems = createItemsArray xs+ }+ where+ createItemsArray :: V.Vector AE.Value -> Maybe (V4Arr.Items D4.Schema)+ createItemsArray =+ (V4Arr.ItemsArray <$>) .+ Utils.listToMaybeList .+ V.toList .+ fmap (jsonToSchemaWithConfig c)++makeArrayAsSingleSchema :: SchemaGenerationConfig -> AE.Array -> D4.Schema+makeArrayAsSingleSchema c xs =+ (makeBasicTypeSchema V4A.SchemaArray) {+ D4._schemaItems =+ Just $ V4Arr.ItemsObject $ fromMaybe D4.emptySchema $ jsonsToSchemaWithConfig c xs+ }++{-| Converts a single JSON document into a JSON schema which the document+ will validate against. Configuration options allow customizing how+ the original JSON document should be interpreted when it is converted+ into a schema.++ The options provided control how even recursively nested schemas will+ be interpreted. There is currently no option to interpret a JSON+ document one way given one path and another way at another path.+-}+jsonToSchemaWithConfig :: SchemaGenerationConfig -> AE.Value -> D4.Schema+jsonToSchemaWithConfig c (AE.Number n) = makeBasicTypeSchema (if DSC.isInteger n then V4A.SchemaInteger else V4A.SchemaNumber)+jsonToSchemaWithConfig c (AE.String s) = makeBasicTypeSchema V4A.SchemaString+jsonToSchemaWithConfig c (AE.Bool s) = makeBasicTypeSchema V4A.SchemaBoolean+jsonToSchemaWithConfig c AE.Null = makeBasicTypeSchema V4A.SchemaNull+jsonToSchemaWithConfig c (AE.Object o) = makeObjectSchema c o+jsonToSchemaWithConfig c (AE.Array xs) = arrayConverter c xs+ where arrayConverter = if typeArraysAsTuples c then makeArrayAsTupleSchema else makeArrayAsSingleSchema++{-| Converts a single JSON document into a JSON schema which the+ document will validate against by using the default options specified+ in 'defaultSchemaGenerationConfig'.+-}+jsonToSchema :: AE.Value -> D4.Schema+jsonToSchema = jsonToSchemaWithConfig defaultSchemaGenerationConfig++{-| Combines multiple schemas into a single schema by folding across them using+ 'unifySchemas'. The 'Maybe' accounts for the case where it is passed+ an empty 'Foldable'.+-}+schemasToSchema :: (Foldable f, Functor f) => f D4.Schema -> Maybe D4.Schema+schemasToSchema = SF.foldr1May unifySchemas++{-| Combines multiple JSON documents into a single schema by first converting each into a schema and+ folding across the schemas using 'unifySchemas'. The documents are converted into schemas using+ the default options specified in 'defaultSchemaGenerationConfig'.+-}+jsonsToSchema :: (Foldable f, Functor f) => f AE.Value -> Maybe D4.Schema+jsonsToSchema = jsonsToSchemaWithConfig defaultSchemaGenerationConfig++{-| Combines multiple JSON documents into a single schema by first converting each into a schema and+ folding across the schemas using 'unifySchemas'. This allows a specific configuration for parsing+ the JSON documents into the schemas to be provided.+-}+jsonsToSchemaWithConfig :: (Foldable f, Functor f) => SchemaGenerationConfig -> f AE.Value -> Maybe D4.Schema+jsonsToSchemaWithConfig c = schemasToSchema . fmap (jsonToSchemaWithConfig c)
+ src/JSONSchema/Draft4/SchemaGenerationConfig.hs view
@@ -0,0 +1,62 @@+{-|+ Module : JSONSchema.Draft4.SchemaGenerationConfig+ Description : Configuration options for schema generation+ Copyright : (c) Gareth Tan, 2017+ License : MIT++ A single JSON document can be interpreted multiple ways and+ with differing degrees of strictness when it is converted+ into a JSON Schema. These options allow the way in which a+ JSON document is converted into a schema to be customized.+-}++module JSONSchema.Draft4.SchemaGenerationConfig+ ( SchemaGenerationConfig(..)+ , defaultSchemaGenerationConfig+ ) where++import Protolude+import Test.QuickCheck (Arbitrary, Gen, arbitrary, sized)++{-| Allows options to be specified for turning an individual JSON document+ into a JSON schema.+-}+data SchemaGenerationConfig = SchemaGenerationConfig++ { typeArraysAsTuples :: Bool+ -- ^ If set to @'True'@, each array will be considered a tuple of type+ -- @(a, b, c...)@ and the schema will be generated so that each member+ -- of the array-tuple will have its own type. If set to False, each+ -- array will be considered to have a single type @Array a@ and the+ -- schemas will be unified accordingly.+ --+ -- In terms of JSON Schema validation, setting this+ -- to @'True'@ will create an @items@ schema that is an array. Setting+ -- it to @'False'@ will create an @items@ schema that is an object.+ , sealObjectProperties :: Bool+ -- ^ If set to @'True'@, then each JSON object that the schema converter+ -- encounters will only be allowed to have all the keys present and+ -- no more. If set to @'False'@, then JSON objects that the schema converter+ -- encounters+ --+ -- In terms of JSON Schema validation, setting 'sealObjectProperties' to+ -- @'True'@ sets @additionalProperties: false@ on each schema object.+ } deriving (Show)++{-| A configuration that can be used as a sane set of defaults when+ converting a JSON Schema into an object. It is used by default+ in 'JSONSchema.Draft4.SchemaGeneration.jsonToSchema' and+ 'JSONSchema.Draft4.SchemaGeneration.jsonsToSchema'.+-}+defaultSchemaGenerationConfig :: SchemaGenerationConfig+defaultSchemaGenerationConfig =+ SchemaGenerationConfig {typeArraysAsTuples = False, sealObjectProperties = False}++instance Arbitrary SchemaGenerationConfig where+ arbitrary = sized f+ where+ f :: Int -> Gen SchemaGenerationConfig+ f n = do+ b1 <- arbitrary+ b2 <- arbitrary+ pure $ SchemaGenerationConfig b1 b2
+ src/JSONSchema/Draft4/SchemaUnification.hs view
@@ -0,0 +1,166 @@+{-|+ Module : JSONSchema.Draft4.SchemaUnification+ Description : Unification of multiple schemas+ Copyright : (c) Gareth Tan, 2017+ License : MIT++ Contains a function to combine multiple JSON schemas+ together.+-}++module JSONSchema.Draft4.SchemaUnification+ ( unifySchemas+ ) where++import Protolude hiding ((<>))++import qualified Data.HashMap.Lazy as HM+import qualified Data.Set as DS+import qualified JSONSchema.Draft4 as D4++import qualified JSONSchema.Validator.Draft4.Array as V4Arr+import qualified JSONSchema.Validator.Draft4.Object as V4Obj++import Data.Semigroup ((<>))++import qualified JSONSchema.Draft4.Internal.Utils as Utils++{-| The primary function used to combine multiple JSON schemas.++ This relation cannot be the binary operation of a monoid because+ the empty schema will act to remove the `required` property of+ any JSON Schema it is unified with.++ This relation is also not commutative because we arbitrarily select+ from the alternatives for properties such as the schema @version@+ that cannot be unified. In addition, when one items schema is+ an array and another is an object, we simply choose arbitrarily+ because there is no sensible way of unifying the schemas while+ preserving all relevant information.+-}+unifySchemas :: D4.Schema -> D4.Schema -> D4.Schema+unifySchemas nextSchema =+ unifyObjectConstraints nextSchema .+ unifyArrayConstraints nextSchema .++ unifyStringConstraints nextSchema .+ unifyNumericConstraints nextSchema .++ unifyAnyInstanceConstraints nextSchema .+ unifyNonvalidatingConstraints nextSchema++-- The linear unifier extracts an array of Maybes and filters them+-- to only the Just values. We then use foldr1May to fold across the+-- list.. If there were no Just values, then+-- the foldr1 fails and we get Nothing. Otherwise, the present Just+-- values are folded together using foldF.++-- |The alternative unifier applies the binary function if both are Just, returns the identity+-- if only one is Just, and Nothing if both are Nothing.+altUnifier :: (a -> a -> a) -> (b -> Maybe a) -> b -> b -> Maybe a+altUnifier binF getter next acc = applied <|> getter next <|> getter acc+ where applied = applicativeUnifier binF getter next acc++-- The applicative unifier applies the binary function but returns Nothing if either+-- is Nothing in the manner of an applicative.+applicativeUnifier :: (a -> a -> a) -> (b -> Maybe a) -> b -> b -> Maybe a+applicativeUnifier binF getter next acc = binF <$> getter next <*> getter acc+++unifyNonvalidatingConstraints :: D4.Schema -> D4.Schema -> D4.Schema+unifyNonvalidatingConstraints nextSchema accSchema = accSchema {+ D4._schemaVersion = altUnifier const D4._schemaVersion nextSchema accSchema+ , D4._schemaId = altUnifier const D4._schemaId nextSchema accSchema+ , D4._schemaRef = altUnifier const D4._schemaRef nextSchema accSchema+ , D4._schemaDefinitions = altUnifier const D4._schemaDefinitions nextSchema accSchema+ , D4._schemaDependencies = altUnifier const D4._schemaDependencies nextSchema accSchema+ , D4._schemaOther = foldr HM.union HM.empty (fmap D4._schemaOther [nextSchema, accSchema])+ }++unifyNumericConstraints :: D4.Schema -> D4.Schema -> D4.Schema+unifyNumericConstraints nextSchema accSchema =+ accSchema+ { D4._schemaMaximum = maxConstraint+ , D4._schemaExclusiveMaximum = emaxConstraint+ , D4._schemaMinimum = minConstraint+ , D4._schemaExclusiveMinimum = eminConstraint+ , D4._schemaMultipleOf = altUnifier const D4._schemaMultipleOf nextSchema accSchema+ }+ where+ schemas = [nextSchema, accSchema]+ maxes = fmap D4._schemaMaximum schemas+ emaxes = fmap D4._schemaExclusiveMaximum schemas+ mins = fmap D4._schemaMinimum schemas+ emins = fmap D4._schemaExclusiveMinimum schemas+ (maxConstraint, emaxConstraint) =+ Utils.computeMaximumConstraints maxes emaxes+ (minConstraint, eminConstraint) =+ Utils.computeMinimumConstraints mins emins++unifyStringConstraints :: D4.Schema -> D4.Schema -> D4.Schema+unifyStringConstraints nextSchema accSchema = accSchema {+ D4._schemaMaxLength = altUnifier max D4._schemaMaxLength nextSchema accSchema+ , D4._schemaMinLength = altUnifier min D4._schemaMinLength nextSchema accSchema+ , D4._schemaPattern = altUnifier const D4._schemaPattern nextSchema accSchema+ }++unifyArrayConstraints :: D4.Schema -> D4.Schema -> D4.Schema+unifyArrayConstraints nextSchema accSchema = accSchema {+ D4._schemaItems = altUnifier unifyItems D4._schemaItems nextSchema accSchema+ , D4._schemaAdditionalItems = altUnifier uAdditional D4._schemaAdditionalItems nextSchema accSchema+ , D4._schemaMaxItems = altUnifier max D4._schemaMaxItems nextSchema accSchema+ , D4._schemaMinItems = altUnifier min D4._schemaMinItems nextSchema accSchema+ , D4._schemaUniqueItems = altUnifier (&&) D4._schemaUniqueItems nextSchema accSchema+ }+ where+ uAdditional :: V4Arr.AdditionalItems D4.Schema -> V4Arr.AdditionalItems D4.Schema -> V4Arr.AdditionalItems D4.Schema+ uAdditional (V4Arr.AdditionalBool b1) (V4Arr.AdditionalBool b2) =+ V4Arr.AdditionalBool $ b1 || b2+ -- allowing additional objects (True) is always at least as permissive as any schema+ -- all schemas are at least as permissive as not allowing any additional objects (False)+ uAdditional bln@(V4Arr.AdditionalBool b) obj@(V4Arr.AdditionalObject s) = if b then bln else obj+ uAdditional obj@(V4Arr.AdditionalObject s) bln@(V4Arr.AdditionalBool b) = if b then bln else obj+ uAdditional (V4Arr.AdditionalObject o1) (V4Arr.AdditionalObject o2) =+ V4Arr.AdditionalObject $ unifySchemas o1 o2++ unifyItems :: V4Arr.Items D4.Schema -> V4Arr.Items D4.Schema -> V4Arr.Items D4.Schema+ unifyItems (V4Arr.ItemsObject o1) (V4Arr.ItemsObject o2) = V4Arr.ItemsObject $ unifySchemas o1 o2+ unifyItems (V4Arr.ItemsArray xs) (V4Arr.ItemsArray ys) = V4Arr.ItemsArray $+ fmap (uncurry unifySchemas) (Utils.zipWithPadding D4.emptySchema D4.emptySchema xs ys)+ unifyItems x y = x -- possibly: merge the object schema into each of the tuple schemas? (zip (repeat o1) xs)++-- If one object does not require properties, then none of them can require+-- any properties. If the `required` array would be empty, we return Nothing+-- instead (the V4 metaschema says the required array cannot be empty)+unifyObjectConstraints :: D4.Schema -> D4.Schema -> D4.Schema+unifyObjectConstraints nextSchema accSchema = accSchema {+ D4._schemaRequired = Utils.setToMaybeSet =<< -- to avoid empty lists, which are not allowed+ applicativeUnifier DS.intersection D4._schemaRequired nextSchema accSchema+ , D4._schemaProperties =+ altUnifier (HM.unionWith unifySchemas) D4._schemaProperties nextSchema accSchema+ , D4._schemaAdditionalProperties =+ altUnifier unify D4._schemaAdditionalProperties nextSchema accSchema+ , D4._schemaMaxProperties = altUnifier max D4._schemaMaxProperties nextSchema accSchema+ , D4._schemaMinProperties = altUnifier min D4._schemaMinProperties nextSchema accSchema+ , D4._schemaPatternProperties = altUnifier (HM.unionWith unifySchemas) D4._schemaPatternProperties nextSchema accSchema+ }+ where+ unify :: V4Obj.AdditionalProperties D4.Schema -> V4Obj.AdditionalProperties D4.Schema -> V4Obj.AdditionalProperties D4.Schema+ unify (V4Obj.AdditionalPropertiesBool b1) (V4Obj.AdditionalPropertiesBool b2) =+ V4Obj.AdditionalPropertiesBool $ b1 || b2+ -- allowing additional objects (True) is always at least as permissive as any schema+ -- all schemas are at least as permissive as not allowing any additional objects (False)+ unify bln@(V4Obj.AdditionalPropertiesBool b) obj@(V4Obj.AdditionalPropertiesObject s) = if b then bln else obj+ unify obj@(V4Obj.AdditionalPropertiesObject s) bln@(V4Obj.AdditionalPropertiesBool b) = if b then bln else obj+ unify (V4Obj.AdditionalPropertiesObject o1) (V4Obj.AdditionalPropertiesObject o2) =+ V4Obj.AdditionalPropertiesObject $ unifySchemas o1 o2++unifyAnyInstanceConstraints :: D4.Schema -> D4.Schema -> D4.Schema+unifyAnyInstanceConstraints nextSchema accSchema = accSchema {+ D4._schemaType = altUnifier (<>) D4._schemaType nextSchema accSchema+ , D4._schemaEnum = altUnifier const D4._schemaEnum nextSchema accSchema+ , D4._schemaAllOf = altUnifier const D4._schemaAllOf nextSchema accSchema+ , D4._schemaAnyOf = altUnifier const D4._schemaAnyOf nextSchema accSchema+ , D4._schemaOneOf = altUnifier const D4._schemaOneOf nextSchema accSchema+ , D4._schemaNot = altUnifier const D4._schemaNot nextSchema accSchema+ }
+ test/JSONSchema/Draft4/ArrayTypeTests.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE QuasiQuotes #-}++module JSONSchema.Draft4.ArrayTypeTests where++import JSONSchema.Draft4.SchemaGenerationConfig+import NeatInterpolation+import Protolude+import Test.Hspec+import TestUtils++tupleTypedArrayConfig :: SchemaGenerationConfig+tupleTypedArrayConfig =+ defaultSchemaGenerationConfig {typeArraysAsTuples = True}++testSingleNonTupleArrayEmpty :: Spec+testSingleNonTupleArrayEmpty =+ it "can generate the schema for a single non-tuple typed array that is empty" $+ let j1 = [text| [] |]+ expected =+ [text|+ {"type": "array", "items": {}}+ |]+ in testJsonsToSchema [j1] expected++testSingleNonTupleArrayMonotype :: Spec+testSingleNonTupleArrayMonotype =+ it "can generate the schema for a single non-tuple typed array of one type" $+ let j1 = [text| ["spam", "spam", "spam", "eggs", "spam"] |]+ expected =+ [text|+ {"type": "array", "items": {"type": "string"}}+ |]+ in testJsonsToSchema [j1] expected++testSingleNonTupleArrayMultitype :: Spec+testSingleNonTupleArrayMultitype =+ it+ "can generate the schema for a single non-tuple typed array of multiple different types" $+ let j1 = [text| [1, "2", null, false] |]+ expected =+ [text|+ {+ "type": "array",+ "items": {+ "type": ["boolean", "integer", "null", "string"]+ }+ }+ |]+ in testJsonsToSchema [j1] expected++testSingleNonTupleArrayNested :: Spec+testSingleNonTupleArrayNested =+ it+ "can generate the schema for a single non-tuple typed array with nested arrays" $+ let j1 =+ [text| [+ ["surprise"],+ ["fear", "surprise"],+ ["fear", "surprise", "ruthless efficiency"],+ ["fear", "surprise", "ruthless efficiency",+ "an almost fanatical devotion to the Pope"]+ ]+ |]+ expected =+ [text|+ {+ "type": "array",+ "items": {+ "type": "array",+ "items": {"type": "string"}}+ }+ |]+ in testJsonsToSchema [j1] expected++testSingleTupleArrayEmpty :: Spec+testSingleTupleArrayEmpty =+ it+ "can generate the schema for a single positionally typed tuple array that is empty" $+ let j1 = [text| [] |]+ expected =+ [text|+ {"type": "array"}+ |]+ in testJsonsToSchemaWithConfig tupleTypedArrayConfig [j1] expected++testSingleTupleArrayMultitype :: Spec+testSingleTupleArrayMultitype =+ it+ "can generate the schema for a single positionally typed tuple array with different types at different positions" $ do+ let j1 = [text| [1, "2", "3", null, false] |]+ let expected =+ [text|+ {+ "type": "array",+ "items": [+ {"type": "integer"},+ {"type": "string"},+ {"type": "string"},+ {"type": "null"},+ {"type": "boolean"}]+ }+ |]+ let invalid1 = [text| [1, 2, "3", null, false] |]+ testJsonsToSchemaWithConfig tupleTypedArrayConfig [j1] expected+ expected `shouldNotValidateTexts` [invalid1]++testSingleTupleArrayNested :: Spec+testSingleTupleArrayNested =+ it+ "can generate the schema for a single positionally typed tuple array that is quite nested" $+ let j1 =+ [text| [+ ["surprise"],+ ["fear", "surprise"],+ ["fear", "surprise", "ruthless efficiency"],+ ["fear", "surprise", "ruthless efficiency",+ "an almost fanatical devotion to the Pope"]+ ] |]+ expected =+ [text|+ {+ "type": "array",+ "items": [+ {+ "type": "array",+ "items": [+ {"type": "string"}+ ]+ },+ {+ "type": "array",+ "items": [+ {"type": "string"},+ {"type": "string"}+ ]+ },+ {+ "type": "array",+ "items": [+ {"type": "string"},+ {"type": "string"},+ {"type": "string"}+ ]+ },+ {+ "type": "array",+ "items": [+ {"type": "string"},+ {"type": "string"},+ {"type": "string"},+ {"type": "string"}+ ]+ }+ ]+ }+ |]+ in testJsonsToSchemaWithConfig tupleTypedArrayConfig [j1] expected++testNonTupleArrayEmpty :: Spec+testNonTupleArrayEmpty =+ it "can generate the schema for multiple non-tuple typed arrays" $+ let j1 = [text| [] |]+ j2 = [text| [] |]+ expected =+ [text|+ {"type": "array", "items": {}}+ |]+ in testJsonsToSchema [j1, j2] expected++testNonTupleArrayMonotype :: Spec+testNonTupleArrayMonotype =+ it+ "can generate the schema for multiple non-tuple typed arrays with only one type" $+ let j1 = [text| ["spam", "spam", "spam", "eggs", "spam"] |]+ j2 = [text| ["spam", "bacon", "eggs", "spam"] |]+ expected =+ [text|+ {"type": "array", "items": {"type": "string"}}+ |]+ in testJsonsToSchema [j1, j2] expected++testNonTupleArrayMultitype :: Spec+testNonTupleArrayMultitype =+ it+ "can generate the schema for multiple non-tuple typed arrays with multiple types" $+ let j1 = [text| [1, "2", "3", null, false] |]+ j2 = [text| [1, 2, "3", false] |]+ expected =+ [text|+ {+ "type":"array",+ "items":{+ "type":[+ "boolean",+ "integer",+ "null",+ "string"+ ]+ }+ }+ |]+ in testJsonsToSchema [j1, j2] expected++testNonTupleArrayNested :: Spec+testNonTupleArrayNested =+ it+ "can generate the schema for multiple non-tuple typed arrays with nested array types" $+ let j1 =+ [text|+ [+ [+ "surprise"+ ],+ [+ "fear",+ "surprise"+ ]+ ]+ |]+ j2 =+ [text|+ [+ ["fear", "surprise", "ruthless efficiency"],+ ["fear", "surprise", "ruthless efficiency",+ "an almost fanatical devotion to the Pope"]+ ]+ |]+ expected =+ [text|+ {+ "type":"array",+ "items":{+ "type":"array",+ "items":{+ "type":"string"+ }+ }+ }+ |]+ in testJsonsToSchema [j1, j2] expected++testTupleArraysEmpty :: Spec+testTupleArraysEmpty =+ it "can generate the schema for multiple tuple typed arrays that are empty" $+ let j1 = [text| [] |]+ j2 = [text| [] |]+ expected =+ [text|+ {"type": "array"}+ |]+ in testJsonsToSchemaWithConfig tupleTypedArrayConfig [j1, j2] expected++testTupleArraysMultitype :: Spec+testTupleArraysMultitype =+ it+ "can generate the schema for multiple tuple typed arrays that have different types in each position" $ do+ let j1 = [text| [1, "2", "3", null, false] |]+ let j2 = [text| [1, 2, "3", false] |]+ let expected =+ [text|+ {+ "type": "array",+ "items": [+ {"type": "integer"},+ {"type": ["integer", "string"]},+ {"type": "string"},+ {"type": ["boolean", "null"]},+ {"type": "boolean"}]+ }+ |]+ let invalid1 = [text| [1, 2, 3, null, false] |]+ testJsonsToSchemaWithConfig tupleTypedArrayConfig [j1, j2] expected+ expected `shouldNotValidateTexts` [invalid1]++testTupleArraysNested :: Spec+testTupleArraysNested =+ it "can generate the schema for multiple tuple typed arrays that are nested" $+ let j1 =+ [text| [+ ["surprise"],+ ["fear", "surprise"]+ ] |]+ j2 =+ [text| [+ ["fear", "surprise", "ruthless efficiency"],+ ["fear", "surprise", "ruthless efficiency",+ "an almost fanatical devotion to the Pope"]+ ] |]+ expected =+ [text|+ {+ "type": "array",+ "items": [+ {+ "type": "array",+ "items": [+ {"type": "string"},+ {"type": "string"},+ {"type": "string"}+ ]+ },+ {+ "type": "array",+ "items": [+ {"type": "string"},+ {"type": "string"},+ {"type": "string"},+ {"type": "string"}+ ]+ }+ ]+ }+ |]+ in testJsonsToSchemaWithConfig tupleTypedArrayConfig [j1, j2] expected
+ test/JSONSchema/Draft4/BasicTypeTests.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE QuasiQuotes #-}++module JSONSchema.Draft4.BasicTypeTests where++import NeatInterpolation+import Protolude+import Test.Hspec+import TestUtils++testBasicTypesSingleStringInstance :: Spec+testBasicTypesSingleStringInstance =+ it "can handle a single instance of a string" $+ let j1 = [text| "string" |]+ expected =+ [text|+ {"type": "string"}+ |]+ in testJsonsToSchema [j1] expected++testBasicTypesSingleIntegerInstance :: Spec+testBasicTypesSingleIntegerInstance =+ it "can handle a single instance of a integer" $+ let j1 = [text| 1 |]+ expected =+ [text|+ {"type": "integer"}+ |]+ in testJsonsToSchema [j1] expected++testBasicTypesSingleNumberInstance :: Spec+testBasicTypesSingleNumberInstance =+ it "can handle a single instance of a number" $+ let j1 = [text| 2.1 |]+ expected =+ [text|+ {"type": "number"}+ |]+ in testJsonsToSchema [j1] expected++testBasicTypesSingleBooleanInstance :: Spec+testBasicTypesSingleBooleanInstance =+ it "can handle a single instance of a boolean" $+ let j1 = [text| true |]+ expected =+ [text|+ {"type": "boolean"}+ |]+ in testJsonsToSchema [j1] expected++testBasicTypesSingleNullInstance :: Spec+testBasicTypesSingleNullInstance =+ it "can handle a single instance of a null" $+ let j1 = [text| null |]+ expected =+ [text|+ {"type": "null"}+ |]+ in testJsonsToSchema [j1] expected++testBasicTypesSingleType :: Spec+testBasicTypesSingleType =+ it "can handle multiple JSON examples of a single type" $+ let j1 = [text| "bacon" |]+ j2 = [text| "eggs" |]+ j3 = [text| "spam" |]+ expected =+ [text|+ {"type": "string"}+ |]+ in testJsonsToSchema [j1, j2, j3] expected++testBasicTypesMultipleType :: Spec+testBasicTypesMultipleType =+ it "can handle multiple JSON examples of multiple different types" $+ let j1 = [text| "bacon" |]+ j2 = [text| 2.2 |]+ j3 = [text| true |]+ j4 = [text| null |]+ expected =+ [text|+ {"type": ["boolean", "null", "number", "string"]}+ |]+ in testJsonsToSchema [j1, j2, j3, j4] expected++testBasicTypesIntegerType :: Spec+testBasicTypesIntegerType =+ it "can handle the Integer type when given an integer" $+ -- TODO: this should eventually unify to just number+ let j1 = [text| 2.14 |]+ j2 = [text| 32 |]+ expected =+ [text|+ {"type": ["number", "integer"]}+ |]+ in testJsonsToSchema [j1, j2] expected
+ test/JSONSchema/Draft4/ComplexTypeTests.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE QuasiQuotes #-}++module JSONSchema.Draft4.ComplexTypeTests where++import JSONSchema.Draft4.SchemaGenerationConfig+import NeatInterpolation+import Protolude+import Test.Hspec+import TestUtils++tupleTypedArrayConfig :: SchemaGenerationConfig+tupleTypedArrayConfig =+ defaultSchemaGenerationConfig {typeArraysAsTuples = True}++sealedObjectPropertiesConfig :: SchemaGenerationConfig+sealedObjectPropertiesConfig =+ defaultSchemaGenerationConfig {sealObjectProperties = True}++testSingleEmptyObject :: Spec+testSingleEmptyObject =+ it "can generate the schema for a single empty object" $+ let j1 = [text| {} |]+ expected = [text| {"type": "object", "properties": {}} |]+ in testJsonsToSchema [j1] expected++testSingleBasicObject :: Spec+testSingleBasicObject =+ it "can generate the schema for a single basic object" $+ let j1 =+ [text| {+ "Red Windsor": "Normally, but today the van broke down.",+ "Stilton": "Sorry.",+ "Gruyere": false+ } |]+ expected =+ [text| {+ "required": ["Gruyere", "Red Windsor", "Stilton"],+ "type": "object",+ "properties": {+ "Red Windsor": {"type": "string"},+ "Gruyere": {"type": "boolean"},+ "Stilton": {"type": "string"}+ }+ } |]+ in testJsonsToSchema [j1] expected++testSingleBasicObjectSealingProperties :: Spec+testSingleBasicObjectSealingProperties =+ it+ "can generate the schema for a single basic object while sealing properties" $+ let j1 =+ [text| {+ "Red Windsor": "Normally, but today the van broke down.",+ "Stilton": "Sorry.",+ "Gruyere": false+ } |]+ expected =+ [text| {+ "required": ["Gruyere", "Red Windsor", "Stilton"],+ "type": "object",+ "properties": {+ "Red Windsor": {"type": "string"},+ "Gruyere": {"type": "boolean"},+ "Stilton": {"type": "string"}+ },+ "additionalProperties": false+ } |]+ in testJsonsToSchemaWithConfig sealedObjectPropertiesConfig [j1] expected++testComplexArrayInObject :: Spec+testComplexArrayInObject =+ it "can generate the schema for arrays that are in objects" $+ let j1 = [text| {"a": "b", "c": [1, 2, 3]} |]+ expected =+ [text| {+ "required": ["a", "c"],+ "type": "object",+ "properties": {+ "a": {"type": "string"},+ "c": {+ "type": "array",+ "items": {"type": "integer"}+ }+ }+ }+ |]+ in testJsonsToSchema [j1] expected++testComplexObjectInArray :: Spec+testComplexObjectInArray =+ it "can generate the schema for objects that are in arrays" $+ let j1 =+ [text| [+ {"name": "Sir Lancelot of Camelot",+ "quest": "to seek the Holy Grail",+ "favorite colour": "blue"},+ {"name": "Sir Robin of Camelot",+ "quest": "to seek the Holy Grail",+ "capitol of Assyria": null+ }]+ |]+ expected =+ [text| {+ "type": "array",+ "items": {+ "type": "object",+ "required": ["name", "quest"],+ "properties": {+ "quest": {"type": "string"},+ "name": {"type": "string"},+ "favorite colour": {"type": "string"},+ "capitol of Assyria": {"type": "null"}+ }+ }+ }+ |]+ in testJsonsToSchema [j1] expected++testComplexObjectInArraySealingProperties :: Spec+testComplexObjectInArraySealingProperties =+ it+ "can generate the schema for objects that are in arrays while sealing properties" $+ let j1 =+ [text| [+ {"name": "Sir Lancelot of Camelot",+ "quest": "to seek the Holy Grail",+ "favorite colour": "blue"},+ {"name": "Sir Robin of Camelot",+ "quest": "to seek the Holy Grail",+ "capitol of Assyria": null+ }]+ |]+ expected =+ [text| {+ "type": "array",+ "items": {+ "type": "object",+ "required": ["name", "quest"],+ "properties": {+ "quest": {"type": "string"},+ "name": {"type": "string"},+ "favorite colour": {"type": "string"},+ "capitol of Assyria": {"type": "null"}+ },+ "additionalProperties": false+ }+ }+ |]+ in testJsonsToSchemaWithConfig sealedObjectPropertiesConfig [j1] expected++testComplexThreeDeepObject :: Spec+testComplexThreeDeepObject =+ it "can generate the schema for a deeply nested object" $+ let j1 = [text| {"matryoshka": {"design": {"principle": "FTW!"}}} |]+ expected =+ [text| {+ "type": "object",+ "required": ["matryoshka"],+ "properties": {+ "matryoshka": {+ "type": "object",+ "required": ["design"],+ "properties": {+ "design": {+ "type": "object",+ "required": ["principle"],+ "properties": {+ "principle": {"type": "string"}+ }+ }+ }+ }+ }+ }+ |]+ in testJsonsToSchema [j1] expected++testComplexThreeDeepObjectSealingProperties :: Spec+testComplexThreeDeepObjectSealingProperties =+ it+ "can generate the schema for a deeply nested object while sealing properties" $+ let j1 = [text| {"matryoshka": {"design": {"principle": "FTW!"}}} |]+ expected =+ [text| {+ "type": "object",+ "required": ["matryoshka"],+ "properties": {+ "matryoshka": {+ "type": "object",+ "required": ["design"],+ "properties": {+ "design": {+ "type": "object",+ "required": ["principle"],+ "properties": {+ "principle": {"type": "string"}+ },+ "additionalProperties": false+ }+ },+ "additionalProperties": false+ }+ },+ "additionalProperties": false+ }+ |]+ in testJsonsToSchemaWithConfig sealedObjectPropertiesConfig [j1] expected++testMultipleEmptyObjects :: Spec+testMultipleEmptyObjects =+ it "can generate the schema for multiple empty objects" $+ let j1 = [text| {} |]+ j2 = [text| {} |]+ expected = [text| {"type": "object", "properties": {}} |]+ in testJsonsToSchema [j1, j2] expected++testEdgeCaseNestedSchema :: Spec+testEdgeCaseNestedSchema =+ it "can generate the schema for strangely nested objects" $+ let j1 =+ [text| [+ [+ null,+ [+ null+ ]+ ],+ {},+ {+ "!": false+ }+ ] |]+ expected =+ [text|+ {+ "items": {+ "items": {+ "items": {+ "type": "null"+ },+ "type": [+ "array",+ "null"+ ]+ },+ "type": [+ "object",+ "array"+ ],+ "properties": {+ "!": {+ "type": "boolean"+ }+ }+ },+ "type": "array"+ }+ |]+ in testJsonsToSchemaPretty [j1] expected
+ test/JSONSchema/Draft4/QuickCheckInstances.hs view
@@ -0,0 +1,236 @@+module JSONSchema.Draft4.QuickCheckInstances where++import Protolude++import qualified Data.Aeson as AE+import qualified Data.HashMap.Lazy as HM+import qualified Data.Vector as V+import JSONSchema.Draft4+import JSONSchema.Validator.Utils++import Data.Generics.Uniplate.Data+import Test.QuickCheck+import Test.QuickCheck.Instances ()++-- N.B. it is in general not true that the empty schema acts as the identity+-- value with regards to unifySchema because the empty schema represents a+-- more relaxed value for required, which we+-- must respect. To get around this, we create a newtype RestrictedSchema+-- which has a different instance of Arbitrary which always returns Nothing for+-- required, thus avoiding this issue.+newtype RestrictedSchema = RestrictedSchema+ { getSchema :: Schema+ } deriving (Show)++instance Arbitrary RestrictedSchema where+ arbitrary = sized f+ where+ maybeGen :: Gen a -> Gen (Maybe a)+ maybeGen a = oneof [pure Nothing, Just <$> a]++ maybeRecurse :: Int -> Gen a -> Gen (Maybe a)+ maybeRecurse n a+ | n < 1 = pure Nothing+ | otherwise = maybeGen $ resize (n `div` 10) a+ f :: Int -> Gen RestrictedSchema+ f n = do+ a <- maybeGen arbitraryText+ b <- maybeGen arbitraryText+ c <- maybeGen arbitraryText+ d <- pure Nothing+ e <- pure mempty+ f' <- maybeGen arbitraryPositiveScientific+ g <- maybeGen arbitraryScientific+ h <- maybeGen arbitrary+ i <- maybeGen arbitraryScientific+ j <- maybeGen arbitrary+ k <- maybeGen (getPositive <$> arbitrary)+ l <- maybeGen (getPositive <$> arbitrary)+ m <- maybeGen arbitraryText+ n' <- maybeGen (getPositive <$> arbitrary)+ o <- maybeGen (getPositive <$> arbitrary)+ p <- arbitrary+ q <- maybeRecurse n arbitrary+ r <- maybeRecurse n arbitrary+ s <- maybeGen (getPositive <$> arbitrary)+ t <- maybeGen (getPositive <$> arbitrary)+ u <- pure Nothing+ v <- maybeRecurse n arbitraryHashMap+ w <- maybeRecurse n arbitraryHashMap+ x <- maybeRecurse n arbitraryHashMap+ y <- maybeRecurse n arbitrary+ z <-+ maybeRecurse n (fmap _unArbitraryValue . _unNonEmpty' <$> arbitrary)+ a2 <- arbitrary+ b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+ c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+ d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+ e2 <- maybeRecurse n arbitrary+ pure $+ RestrictedSchema+ Schema {+ _schemaVersion = a+ , _schemaId = b+ , _schemaRef = c+ , _schemaDefinitions = d+ , _schemaOther = e+ , _schemaMultipleOf = f'+ , _schemaMaximum = g+ , _schemaExclusiveMaximum = h+ , _schemaMinimum = i+ , _schemaExclusiveMinimum = j+ , _schemaMaxLength = k+ , _schemaMinLength = l+ , _schemaPattern = m+ , _schemaMaxItems = n'+ , _schemaMinItems = o+ , _schemaUniqueItems = p+ , _schemaItems = q+ , _schemaAdditionalItems = r+ , _schemaMaxProperties = s+ , _schemaMinProperties = t+ , _schemaRequired = u+ , _schemaDependencies = v+ , _schemaProperties = w+ , _schemaPatternProperties = x+ , _schemaAdditionalProperties = y+ , _schemaEnum = z+ , _schemaType = a2+ , _schemaAllOf = b2+ , _schemaAnyOf = c2+ , _schemaOneOf = d2+ , _schemaNot = e2+ }++-- For properties that cannot be easily unified we simply choose+-- one (e.g. "version": "1.0" and "version": "2.0"). By excluding+-- these properties, unified with `const`, we can test if a+-- unifySchema is commutative otherwise+newtype CommutativeSchema = CommutativeSchema+ { getCommutativeSchema :: Schema+ } deriving (Show)++instance Arbitrary CommutativeSchema where+ arbitrary = sized f+ where+ maybeGen :: Gen a -> Gen (Maybe a)+ maybeGen a = oneof [pure Nothing, Just <$> a]+ maybeRecurse :: Int -> Gen a -> Gen (Maybe a)+ maybeRecurse n a+ | n < 1 = pure Nothing+ | otherwise = maybeGen $ resize (n `div` 10) a+ f :: Int -> Gen CommutativeSchema+ f n = do+ a <- pure Nothing+ b <- pure Nothing+ c <- pure Nothing+ d <- pure Nothing+ e <- pure mempty+ f' <- pure Nothing+ g <- maybeGen arbitraryScientific+ h <- maybeGen arbitrary+ i <- maybeGen arbitraryScientific+ j <- maybeGen arbitrary+ k <- maybeGen (getPositive <$> arbitrary)+ l <- maybeGen (getPositive <$> arbitrary)+ m <- pure Nothing+ n' <- maybeGen (getPositive <$> arbitrary)+ o <- maybeGen (getPositive <$> arbitrary)+ p <- arbitrary+ q <- maybeRecurse n arbitrary+ r <- maybeRecurse n arbitrary+ s <- maybeGen (getPositive <$> arbitrary)+ t <- maybeGen (getPositive <$> arbitrary)+ u <- pure Nothing+ v <- pure Nothing+ w <- maybeRecurse n arbitraryHashMap+ x <- maybeRecurse n arbitraryHashMap+ y <- maybeRecurse n arbitrary+ z <- pure Nothing+ a2 <- arbitrary+ b2 <- pure Nothing+ c2 <- pure Nothing+ d2 <- pure Nothing+ e2 <- pure Nothing+ pure $+ CommutativeSchema+ Schema {+ _schemaVersion = a+ , _schemaId = b+ , _schemaRef = c+ , _schemaDefinitions = d+ , _schemaOther = e+ , _schemaMultipleOf = f'+ , _schemaMaximum = g+ , _schemaExclusiveMaximum = h+ , _schemaMinimum = i+ , _schemaExclusiveMinimum = j+ , _schemaMaxLength = k+ , _schemaMinLength = l+ , _schemaPattern = m+ , _schemaMaxItems = n'+ , _schemaMinItems = o+ , _schemaUniqueItems = p+ , _schemaItems = q+ , _schemaAdditionalItems = r+ , _schemaMaxProperties = s+ , _schemaMinProperties = t+ , _schemaRequired = u+ , _schemaDependencies = v+ , _schemaProperties = w+ , _schemaPatternProperties = x+ , _schemaAdditionalProperties = y+ , _schemaEnum = z+ , _schemaType = a2+ , _schemaAllOf = b2+ , _schemaAnyOf = c2+ , _schemaOneOf = d2+ , _schemaNot = e2+ }++-- Arbitrary instance for Value from Reddit.+instance Arbitrary AE.Value where+ arbitrary = sized sizedArbitraryValue+ -- JSON shrinker borrowed from json-autotype+ shrink = valueShrink++sizedArbitraryValue :: Int -> Gen AE.Value+sizedArbitraryValue n+ | n <= 0 =+ oneof+ [ pure AE.Null+ , AE.Bool <$> arbitrary+ , AE.Number <$> arbitrary+ , AE.String <$> arbitrary+ ]+ | otherwise =+ resize (div n 2) $+ oneof+ [ pure AE.Null+ , AE.Bool <$> arbitrary+ , AE.Number <$> arbitrary+ , AE.String <$> arbitrary+ , AE.Array <$> arbitrary+ , AE.Object <$> arbitrary+ ]++simpleShrink :: AE.Value -> [AE.Value]+simpleShrink (AE.Array a) = map (AE.Array . V.fromList) $ shrink $ V.toList a+simpleShrink (AE.Object o) =+ map (AE.Object . HM.fromList) $ shrink $ HM.toList o+simpleShrink _ = [] -- Nothing for simple objects++valueShrink :: AE.Value -> [AE.Value]+valueShrink = concatMap simpleShrink . universe++sizedJsonProp :: Int -> (AE.Value -> Property) -> Property+sizedJsonProp size = forAllShrink jsonGen valueShrink+ where+ jsonGen :: Gen AE.Value+ jsonGen = resize size arbitrary++sizedJsonsProp :: Int -> ([AE.Value] -> Property) -> Property+sizedJsonsProp size = forAllShrink jsonGen $ shrinkList valueShrink+ where+ jsonGen :: Gen [AE.Value]+ jsonGen = resize size arbitrary
+ test/JSONSchema/Draft4/QuickCheckTests.hs view
@@ -0,0 +1,134 @@+module JSONSchema.Draft4.QuickCheckTests where++import Protolude++import qualified Data.Aeson as AE+import JSONSchema.Draft4++import qualified JSONSchema.Draft4 as D4+import JSONSchema.Draft4.SchemaGeneration as JSSC+import JSONSchema.Draft4.SchemaGenerationConfig++import qualified GHC.Base+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import TestUtils+import JSONSchema.Draft4.QuickCheckInstances++tupleTypedArrayConfig :: SchemaGenerationConfig+tupleTypedArrayConfig =+ defaultSchemaGenerationConfig {typeArraysAsTuples = True}++sealedObjectPropertiesConfig :: SchemaGenerationConfig+sealedObjectPropertiesConfig =+ defaultSchemaGenerationConfig {sealObjectProperties = True}++++explainSchemaCounterexample ::+ [AE.Value] -> D4.Schema -> SchemaGenerationConfig -> GHC.Base.String+explainSchemaCounterexample jsons schema config =+ "The JSONs " <> foldr (<>) "" (fmap printJsonToString jsons) <>+ " do not all validate against their generated schema " <>+ printSchemaToString schema <>+ " when run with configuration " <>+ show config++explainSchemaCommutative ::+ D4.Schema -> D4.Schema -> GHC.Base.String+explainSchemaCommutative s1 s2 =+ "These schemas could not be united commutatively:" <>+ printSchemaToString s1 <>+ printSchemaToString s2 <>+ "When s1 was unified into s2 the result was \n" <>+ printSchemaToString (unifySchemas s1 s2) <>+ " but when s2 was unified into s1 the result was\n " <>+ printSchemaToString (unifySchemas s2 s1)++explainSchemaSelfUnify ::+ D4.Schema -> GHC.Base.String+explainSchemaSelfUnify s =+ "This schema did not properly unify with itself:" <>+ printSchemaToString s <>+ "When it was unified with itself it should have stayed the same but the result instead was \n" <>+ printSchemaToString (unifySchemas s s)++testPropUnifyEmptySchemaRightIdentity :: Spec+testPropUnifyEmptySchemaRightIdentity =+ prop+ "will not change a restricted schema when an empty schema is passed in on the right"+ p+ where+ p :: RestrictedSchema -> Bool+ p rs = JSSC.unifySchemas (getSchema rs) emptySchema == getSchema rs++testPropUnifyEmptySchemaLeftIdentity :: Spec+testPropUnifyEmptySchemaLeftIdentity =+ prop+ "will not change a restricted schema when an empty schema is passed in on the left"+ p+ where+ p :: RestrictedSchema -> Bool+ p rs = JSSC.unifySchemas emptySchema (getSchema rs) == getSchema rs++-- Unable yet to generate recursively commutative schemas+testSchemaUnificationCommutative :: Spec+testSchemaUnificationCommutative =+ modifyMaxSize (const 1) $+ prop "schema unification of a schema with non-const properties is commutative" propUnificationCommutative+ where+ propUnificationCommutative :: CommutativeSchema -> CommutativeSchema -> Property+ propUnificationCommutative r1 r2 =+ counterexample (explainSchemaCommutative s1 s2) (unifySchemas s1 s2 == unifySchemas s2 s1)+ where+ s1 = getCommutativeSchema r1+ s2 = getCommutativeSchema r2++-- Unable yet to generate nested schemas without `required`, which must not be empty.+testSchemaUnifiedWithSelfIsSelf :: Spec+testSchemaUnifiedWithSelfIsSelf =+ modifyMaxSize (const 1) $+ prop "when a schema is unified with itself it does not change" propSelfUnification+ where+ propSelfUnification :: RestrictedSchema -> Property+ propSelfUnification s =+ counterexample (explainSchemaSelfUnify rs) (unifySchemas rs rs == rs )+ where rs = getSchema s++testJsonToSchemaWithConfigValidatesJson :: Spec+testJsonToSchemaWithConfigValidatesJson =+ prop+ "will generate a schema that can validate the JSON used to generate the schema with a randomized configuration"+ configurer+ where+ configurer :: SchemaGenerationConfig -> Property+ configurer config = sizedJsonProp 7 (p config)+ p :: SchemaGenerationConfig -> AE.Value -> Property+ p config json =+ counterexample+ (explainSchemaCounterexample [json] schema config)+ (schema `validatesAll` [json])+ where+ schema = JSSC.jsonToSchemaWithConfig config json++testSchemaUnificationValidatesAllJson :: Spec+testSchemaUnificationValidatesAllJson =+ prop+ "will generate a schema that validates all the JSON documents unified to produce it"+ configurer+ where+ configurer :: SchemaGenerationConfig -> Property+ configurer config = sizedJsonsProp 7 (p config)+ p :: SchemaGenerationConfig -> [AE.Value] -> Property+ p config jsons =+ counterexample+ (explainSchemaCounterexample jsons schema config)+ (schema `validatesAll` jsons)+ where+ schema =+ fromMaybe+ (panic "Could not parse schemas")+ (JSSC.jsonsToSchemaWithConfig config jsons)+
+ test/JSONSchema/Draft4/SchemaConverterSpec.hs view
@@ -0,0 +1,63 @@+module JSONSchema.Draft4.SchemaConverterSpec where++import JSONSchema.Draft4.ArrayTypeTests+import JSONSchema.Draft4.BasicTypeTests+import JSONSchema.Draft4.ComplexTypeTests+import JSONSchema.Draft4.QuickCheckTests+import Protolude+import Test.Hspec++-- Many of these tests are borrowed from Python's GenSON+-- https://github.com/wolverdude/GenSON++spec :: Spec+spec = do+ describe "Single Instances of Basic Types" $ do+ testBasicTypesSingleStringInstance+ testBasicTypesSingleIntegerInstance+ testBasicTypesSingleNumberInstance+ testBasicTypesSingleBooleanInstance+ testBasicTypesSingleNullInstance+ describe "Combining Multiple Instances of Basic Types" $ do+ testBasicTypesSingleType+ testBasicTypesMultipleType+ testBasicTypesIntegerType+ describe "Single Instances of the Non-Tuple Array Type" $ do+ testSingleNonTupleArrayEmpty+ testSingleNonTupleArrayMonotype+ testSingleNonTupleArrayMultitype+ testSingleNonTupleArrayNested+ describe "Single Instances of the Tuple Array Type" $ do+ testSingleTupleArrayEmpty+ testSingleTupleArrayMultitype+ testSingleTupleArrayNested+ describe "Single Instances of Object Types" $ do+ testSingleEmptyObject+ testSingleBasicObject+ testSingleBasicObjectSealingProperties+ describe "Single Instances of More Complex Types" $ do+ testComplexArrayInObject+ testComplexObjectInArray+ testComplexObjectInArraySealingProperties+ testComplexThreeDeepObject+ testComplexThreeDeepObjectSealingProperties+ testEdgeCaseNestedSchema+ describe "Combining Multiple Instances of the Non-Tuple Array Type" $ do+ testNonTupleArrayEmpty+ testNonTupleArrayMonotype+ testNonTupleArrayMultitype+ testNonTupleArrayNested+ describe "Combining Multiple Instances of the Tuple Array Type" $ do+ testTupleArraysEmpty+ testTupleArraysMultitype+ testTupleArraysNested+ describe+ "Combining Multiple Instances of Object Types"+ testMultipleEmptyObjects+ describe "Schema Properties" $ do+ testPropUnifyEmptySchemaRightIdentity+ testPropUnifyEmptySchemaLeftIdentity+ testSchemaUnificationCommutative+ testSchemaUnifiedWithSelfIsSelf+ testJsonToSchemaWithConfigValidatesJson+ testSchemaUnificationValidatesAllJson
+ test/JSONSchema/Draft4/UnifiersSpec.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE QuasiQuotes #-}++module JSONSchema.Draft4.UnifiersSpec where++import JSONSchema.Draft4+import NeatInterpolation+import Protolude+import Test.Hspec+import TestUtils++testUnifyEmptySchemas :: Spec+testUnifyEmptySchemas =+ it "will unify two empty schemas" $+ testUnifySchemas emptySchema emptySchema emptySchema++testUnifySingleValueConstraints :: Spec+testUnifySingleValueConstraints =+ it "will unify schemas with single values" $+ let s1 =+ [text|+ {+ "version": "1.0.0"+ }+ |]+ s2 =+ [text|+ {+ "version": "2.4.6"+ }+ |]+ expected =+ [text|+ {+ "version": "1.0.0"+ }+ |]+ in testUnifySchemaTexts s1 s2 expected++testUnifyMultipleSingleValueConstraints :: Spec+testUnifyMultipleSingleValueConstraints =+ it "will unify schemas with single values" $+ let s1 =+ [text|+ {+ "version": "1.0.0",+ "id": "x-1234"+ }+ |]+ s2 =+ [text|+ {+ "version": "2.4.6",+ "id": "x-2019",+ "pattern": ".+"+ }+ |]+ expected =+ [text|+ {+ "version": "1.0.0",+ "id": "x-1234",+ "pattern": ".+"+ }+ |]+ in testUnifySchemaTexts s1 s2 expected++spec :: Spec+spec =+ describe "Basic Unification" $ do+ testUnifyEmptySchemas+ testUnifySingleValueConstraints+ testUnifyMultipleSingleValueConstraints
+ test/Main.hs view
@@ -0,0 +1,13 @@+module Main where++import Protolude++import qualified Spec+import Test.Hspec.Runner+import System.Environment++main :: IO ()+main = do+ environment <- lookupEnv "JSON_ENVIRONMENT"+ let isLocal = fromMaybe "" environment == "local"+ hspecWith defaultConfig {configQuickCheckMaxSuccess = if isLocal then Just 10000 else Nothing} Spec.spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ test/TestUtils.hs view
@@ -0,0 +1,125 @@+module TestUtils+ ( testJsonToSchema+ , testJsonsToSchema+ , testJsonsToSchemaWithConfig+ , testJsonsToSchemaPretty+ , testJsonsToSchemaPrettyWithConfig+ , shouldValidate+ , shouldNotValidate+ , shouldNotValidateTexts+ , validatesAll+ , testUnifySchemas+ , testUnifySchemaTexts+ , printJson+ , printJsonToString+ , printSchemaToString+ ) where++import Protolude++import qualified Data.Aeson as AE+import qualified Data.Aeson.Encode.Pretty as AEEP+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Char8 as BSC+import qualified Data.HashMap.Lazy as HM+import qualified Data.Text.Encoding as TE+import qualified JSONSchema.Draft4 as D4++import JSONSchema.Draft4.SchemaGeneration+import JSONSchema.Draft4.SchemaGenerationConfig+import Test.Hspec++import qualified GHC.Base++parseSchema :: Text -> D4.Schema+parseSchema s =+ fromMaybe (panic $ "Failed to parse schema " <> s) .+ AE.decode .+ BSL.fromStrict .+ TE.encodeUtf8 $ s++printSchema :: D4.Schema -> BSL.ByteString+printSchema = AEEP.encodePretty . AE.toJSON++printJson :: AE.Value -> BSL.ByteString+printJson = AEEP.encodePretty++printJsonToString :: AE.Value -> GHC.Base.String+printJsonToString = BSC.unpack . BSL.toStrict . printJson++printSchemaToString :: D4.Schema -> GHC.Base.String+printSchemaToString = BSC.unpack . BSL.toStrict . printSchema+++parseJson :: Text -> AE.Value+parseJson json =+ (fromMaybe (panic $ "Could not parse JSON " <> json) .+ AE.decode . BSL.fromStrict . TE.encodeUtf8)+ json++validatesAll :: D4.Schema -> [AE.Value] -> Bool+validatesAll schema jsons = and $ validator <$> jsons+ where validatableSchema = D4.SchemaWithURI schema Nothing+ possibleValidator = D4.checkSchema (D4.URISchemaMap HM.empty) validatableSchema+ validator :: AE.Value -> Bool+ validator = either (\err value -> False) (null .) possibleValidator++shouldValidate :: D4.Schema -> [AE.Value] -> IO ()+shouldValidate schema jsons = do+ let validatableSchema = D4.SchemaWithURI schema Nothing+ results <- sequence $ fmap (D4.fetchFilesystemAndValidate validatableSchema) jsons+ results `shouldBe` replicate (length jsons) (Right ())++shouldNotValidateTexts :: Text -> [Text] -> IO ()+shouldNotValidateTexts expectedSchema jsonTexts = do+ let jsonInstances = fmap parseJson jsonTexts+ let schema = parseSchema expectedSchema++ schema `shouldNotValidate` jsonInstances++shouldNotValidate :: D4.Schema -> [AE.Value] -> IO ()+shouldNotValidate schema jsons = do+ let validatableSchema = D4.SchemaWithURI schema Nothing+ results <- sequence $ fmap (D4.fetchFilesystemAndValidate validatableSchema) jsons++ all isLeft results `shouldBe` True+++testJsonToSchema :: Text -> Text -> IO ()+testJsonToSchema jsonText = testJsonsToSchema [jsonText]++testJsonsToSchemaWithConfig :: SchemaGenerationConfig -> [Text] -> Text -> IO ()+testJsonsToSchemaWithConfig c jsonTexts expectedSchema = do+ let jsonInstances = fmap parseJson jsonTexts+ let computedSchema = fromMaybe+ (panic "Could not unify multiple schemas")+ (jsonsToSchemaWithConfig c jsonInstances)++ -- Check schema is as expected+ computedSchema `shouldBe` parseSchema expectedSchema++ -- Check all provided instances validate against the computed schema+ let validatableSchema = D4.SchemaWithURI computedSchema Nothing+ results <- sequence $ fmap (D4.fetchFilesystemAndValidate validatableSchema) jsonInstances++ results `shouldBe` replicate (length jsonInstances) (Right ())++testJsonsToSchema :: [Text] -> Text -> IO ()+testJsonsToSchema = testJsonsToSchemaWithConfig defaultSchemaGenerationConfig++testJsonsToSchemaPrettyWithConfig :: SchemaGenerationConfig -> [Text] -> Text -> IO ()+testJsonsToSchemaPrettyWithConfig c jsonTexts expectedSchema =+ maybe+ (panic "Could not unify multiple schemas")+ printSchema+ (jsonsToSchemaWithConfig c $ fmap parseJson jsonTexts) `shouldBe`+ printSchema (parseSchema expectedSchema)++testJsonsToSchemaPretty :: [Text] -> Text -> IO ()+testJsonsToSchemaPretty = testJsonsToSchemaPrettyWithConfig defaultSchemaGenerationConfig++testUnifySchemaTexts :: Text -> Text -> Text -> IO ()+testUnifySchemaTexts s1 s2 expected = testUnifySchemas (parseSchema s1) (parseSchema s2) (parseSchema expected)++testUnifySchemas :: D4.Schema -> D4.Schema -> D4.Schema -> IO ()+testUnifySchemas s1 s2 expected = unifySchemas s1 s2 `shouldBe` expected
+ test/UtilsSpec.hs view
@@ -0,0 +1,129 @@+module UtilsSpec where++import Data.Scientific+import JSONSchema.Draft4.Internal.Utils+import Test.Hspec++import Protolude++spec :: Spec+spec = do+ describe "Maximum Constraint Tests" maximumConstraintTests+ describe "Minimum Constraint Tests" minimumConstraintTests++maximumConstraintTests :: Spec+maximumConstraintTests = do+ it "will compute a maximum from some numbers" $+ computeMaximumConstraints+ [ Just $ scientific 20 1+ , Just $ scientific 30 1+ , Nothing+ , Nothing+ , Just $ scientific 25 1+ ]+ [Just True, Just False, Nothing, Just True, Just True] `shouldBe`+ (Just $ scientific 30 1, Just False)++ it "will not be clobbered by a nothing" $+ computeMaximumConstraints+ [ Just $ scientific 20 1+ , Nothing+ ]+ [Just True, Just False] `shouldBe`+ (Just $ scientific 20 1, Just True)++ it "will not be clobbered by False when both are nothing " $+ computeMaximumConstraints+ [ Nothing+ , Nothing+ ]+ [Just False, Just True] `shouldBe`+ (Nothing, Just True)++ it "will not be clobbered by Nothing when both are nothing " $+ computeMaximumConstraints+ [ Nothing+ , Nothing+ ]+ [Nothing, Just True] `shouldBe`+ (Nothing, Just True)++ it+ "will compute a maximum from the existence of an exclusive maximum when there is a tie" $+ computeMaximumConstraints+ [ Just $ scientific 59 1+ , Just $ scientific 52 1+ , Nothing+ , Just $ scientific 59 1+ , Nothing+ ]+ [Just False, Just True, Just True, Just True, Just True] `shouldBe`+ (Just $ scientific 59 1, Just False)+ it "will be able to return a sensible value when nothing is defined" $+ computeMaximumConstraints+ [Nothing, Nothing, Nothing]+ [Nothing, Nothing, Nothing] `shouldBe`+ (Nothing, Nothing)++minimumConstraintTests :: Spec+minimumConstraintTests = do+ it "will compute a minimum from some numbers" $+ computeMinimumConstraints+ [ Just $ scientific 20 1+ , Just $ scientific 30 1+ , Nothing+ , Nothing+ , Just $ scientific 25 1+ ]+ [Just True, Just False, Nothing, Just True, Just True] `shouldBe`+ (Just $ scientific 20 1, Just True)++ it "will not be clobbered by a nothing" $+ computeMinimumConstraints+ [ Just $ scientific 20 1+ , Nothing+ ]+ [Just True, Just False] `shouldBe`+ (Just $ scientific 20 1, Just True)++ it "will not be clobbered by False when both are nothing " $+ computeMinimumConstraints+ [ Nothing+ , Nothing+ ]+ [Just False, Just True] `shouldBe`+ (Nothing, Just True)++ it "will not be clobbered by Nothing when both are nothing " $+ computeMinimumConstraints+ [ Nothing+ , Nothing+ ]+ [Nothing, Just True] `shouldBe`+ (Nothing, Just True)++ it+ "will compute a minimum from the existence of an exclusive minimum when there is a tie" $+ computeMinimumConstraints+ [ Just $ scientific 59 1+ , Nothing+ , Just $ scientific 12 1+ , Just $ scientific 14 1+ , Just $ scientific 12 1+ , Just $ scientific 59 1+ , Nothing+ ]+ [ Just False+ , Just True+ , Just True+ , Just True+ , Just False+ , Just False+ , Just True+ ] `shouldBe`+ (Just $ scientific 12 1, Just False)+ it "will be able to return a sensible value when nothing is defined" $+ computeMinimumConstraints+ [Nothing, Nothing, Nothing]+ [Nothing, Nothing, Nothing] `shouldBe`+ (Nothing, Nothing)