diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,2 +1,5 @@ -# haskell-hedgehog-gen-json -JSON Gen for Hedgehog +[![Build Status](https://travis-ci.org/amrhassan/haskell-hedgehog-gen-json.svg?branch=master)](https://travis-ci.org/amrhassan/haskell-hedgehog-gen-json) +[![Hackage version](https://img.shields.io/hackage/v/hedgehog-gen-json.svg?label=Hackage)](https://hackage.haskell.org/package/hedgehog-gen-json) +[![Stackage version](https://www.stackage.org/package/hedgehog-gen-json/badge/lts?label=Stackage)](https://www.stackage.org/package/hedgehog-gen-json) + +JSON generators for [Hedgehog](https://github.com/hedgehogqa). diff --git a/hedgehog-gen-json.cabal b/hedgehog-gen-json.cabal --- a/hedgehog-gen-json.cabal +++ b/hedgehog-gen-json.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: aaf5869b8143146c3771604d497a1884654598a47bc908828bf2563742f29117 +-- hash: 19509d71ae99a04870b3c2924858c720249638f0ff47c4c07a0545c172c51681 name: hedgehog-gen-json -version: 0.0.0 +version: 0.1.0 synopsis: JSON generators for Hedgehog description: Generate JSON values for Hedgehog tests category: Test @@ -24,19 +24,29 @@ library hs-source-dirs: src + ghc-options: -Wall build-depends: aeson , base >=4.7 && <5 , bytestring + , containers + , exceptions , hedgehog - , hjsonschema , lens , protolude + , regex-genex , scientific + , text + , unordered-containers , vector exposed-modules: Hedgehog.Gen.JSON other-modules: + Hedgehog.Gen.JSON.Constrained + Hedgehog.Gen.JSON.Constrained.Internal + Hedgehog.Gen.JSON.JSONSchema + Hedgehog.Gen.JSON.Ranges + Hedgehog.Gen.JSON.Unconstrained Paths_hedgehog_gen_json default-language: Haskell2010 @@ -46,19 +56,32 @@ hs-source-dirs: src test + ghc-options: -Wall build-depends: aeson , base >=4.7 && <5 , bytestring + , containers + , exceptions , hedgehog - , hjsonschema , lens , protolude + , regex-genex + , regex-posix , scientific , tasty , tasty-hedgehog + , text + , unordered-containers , vector other-modules: Hedgehog.Gen.JSON + Hedgehog.Gen.JSON.Constrained + Hedgehog.Gen.JSON.Constrained.Internal + Hedgehog.Gen.JSON.JSONSchema + Hedgehog.Gen.JSON.Ranges + Hedgehog.Gen.JSON.Unconstrained + Hedgehog.Gen.JSON.Constrained.Internal.InternalSpec + Hedgehog.Gen.JSON.JSONSpec Paths_hedgehog_gen_json default-language: Haskell2010 diff --git a/src/Hedgehog/Gen/JSON.hs b/src/Hedgehog/Gen/JSON.hs --- a/src/Hedgehog/Gen/JSON.hs +++ b/src/Hedgehog/Gen/JSON.hs @@ -1,97 +1,72 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeSynonymInstances #-} module Hedgehog.Gen.JSON ( genJSON + , genJSONValue + , genConstrainedJSON + , genConstrainedJSONValue + , Schema + , readSchema , Ranges(..) , NumberRange(..) , StringRange(..) , ArrayRange(..) , ObjectRange(..) + , sensibleRanges ) where -import Control.Lens -import qualified Data.Aeson as A -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Scientific as Scientific -import qualified Data.Vector as Vector +import Control.Monad.Catch (MonadThrow, throwM) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified JSONSchema.Draft4 as D4 +import qualified Hedgehog.Gen.JSON.Constrained as Constrained +import Hedgehog.Gen.JSON.JSONSchema (Schema) +import Hedgehog.Gen.JSON.Ranges +import qualified Hedgehog.Gen.JSON.Unconstrained as Unconstrained +import qualified Hedgehog.Range as Range import Protolude -newtype NumberRange = NumberRange - { unNumberRange :: Range Double - } - -newtype StringRange = StringRange - { unStringRange :: Range Int - } - -newtype ArrayRange = ArrayRange - { unArrayRange :: Range Int - } - -newtype ObjectRange = ObjectRange - { unObjectRange :: Range Int - } - -data Ranges = Ranges - { _numberRange :: NumberRange - , _stringRange :: StringRange - , _arrayRange :: ArrayRange - , _objectRange :: ObjectRange - } - -makeLenses ''Ranges - -readSchema :: FilePath -> IO (Either Text D4.Schema) +-- | Reads a JSON Schema from a filepath +readSchema :: (MonadIO m, MonadThrow m) => FilePath -> m Schema readSchema fp = do - bytes <- BS.readFile fp - pure $ maybeToEither "failed to decode JSON Schema" (A.decodeStrict bytes) - -genNull :: Gen A.Value -genNull = pure A.Null + bytes <- liftIO $ BS.readFile fp + case Aeson.eitherDecodeStrict bytes of + Left err -> throwM $ DecodingSchemaException $ Text.pack err + Right schema -> pure schema -genString :: StringRange -> Gen A.Value -genString sr = A.String <$> Gen.text (unStringRange sr) Gen.unicode +-- | Generator for arbitrary unconstrained JSON values encoded as UTF-8 +genJSON :: Ranges -> Gen ByteString +genJSON ranges = (LBS.toStrict . Aeson.encode) <$> genJSONValue ranges -genBool :: Gen A.Value -genBool = A.Bool <$> Gen.bool +-- | Generator for arbitrary unconstrained JSON values +genJSONValue :: Ranges -> Gen Aeson.Value +genJSONValue = Unconstrained.genValue -genNumber :: NumberRange -> Gen A.Value -genNumber nr = (A.Number . Scientific.fromFloatDigits) <$> Gen.double (unNumberRange nr) +-- | Generator for arbitrary JSON values constrained by the given JSON Schema and encoded as UTF-8 +genConstrainedJSON :: Ranges -> Schema -> Gen ByteString +genConstrainedJSON ranges schema = (LBS.toStrict . Aeson.encode) <$> genConstrainedJSONValue ranges schema -genArray :: Ranges -> Gen A.Value -genArray ranges = do - let gen = - Gen.recursive - Gen.choice - [genBool, genNumber (ranges ^. numberRange), genString (ranges ^. stringRange)] - [genArray ranges, genObj ranges] - (A.Array . Vector.fromList) <$> Gen.list (unArrayRange (ranges ^. arrayRange)) gen +-- | Generator for arbitrary JSON values constrained by the given JSON Schema +genConstrainedJSONValue :: Ranges -> Schema -> Gen Aeson.Value +genConstrainedJSONValue = Constrained.genValue -genObj :: Ranges -> Gen A.Value -genObj ranges = - A.object <$> - Gen.list - (unArrayRange (ranges ^. arrayRange)) - ((,) <$> Gen.text (unStringRange (ranges ^. stringRange)) Gen.unicode <*> genValue ranges) +-- | Sensible ranges for arbitrary JSON values if you're too lazy to define some +sensibleRanges :: Ranges +sensibleRanges = + Ranges + { _arrayRange = ArrayRange $ Range.linear 0 5 + , _stringRange = StringRange $ Range.linear 0 1000 + , _numberRange = NumberRange $ Range.linearFrac (-1000) 1000 + , _integerRange = IntegerRange $ Range.linear (-1000) 1000 + , _objectRange = ObjectRange $ Range.linear 0 5 + } -genValue :: Ranges -> Gen A.Value -genValue ranges = - Gen.choice - [ genNull - , genString (ranges ^. stringRange) - , genBool - , genNumber (ranges ^. numberRange) - , genArray ranges - , genObj ranges - ] +newtype JSONException = + DecodingSchemaException Text + deriving (Show, Eq) -genJSON :: Ranges -> Gen ByteString -genJSON ranges = (LBS.toStrict . A.encode) <$> genValue ranges ---genFakeJson :: D4.Schema -> Gen Value ---genFakeJson = undefined +instance Exception JSONException diff --git a/src/Hedgehog/Gen/JSON/Constrained.hs b/src/Hedgehog/Gen/JSON/Constrained.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Gen/JSON/Constrained.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hedgehog.Gen.JSON.Constrained + ( genValue + , Schema + ) where + +import Control.Lens +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Scientific as Scientific +import qualified Data.Vector as Vector +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen.JSON.Constrained.Internal +import Hedgehog.Gen.JSON.JSONSchema +import Hedgehog.Gen.JSON.Ranges +import qualified Hedgehog.Gen.JSON.Unconstrained as Unconstrained +import qualified Hedgehog.Range as Range +import Protolude + +genValue :: Ranges -> Schema -> Gen Aeson.Value +genValue ranges schema + | isJust (schema ^. schemaEnum) = + case schema ^. schemaEnum of + Just (AnyConstraintEnum vs) -> (Gen.element . toList) vs + Nothing -> empty + | isJust (schema ^. schemaConst) = + case schema ^. schemaConst of + Just (AnyConstraintConst c) -> pure c + Nothing -> empty + | otherwise = + case schema ^. schemaType of + Nothing -> Unconstrained.genValue ranges + Just (MultipleTypes (t :| [])) -> genValue ranges (set schemaType (Just $ SingleType t) schema) + Just (MultipleTypes (t :| [t'])) -> + Gen.choice + [ genValue ranges (set schemaType (Just $ SingleType t) schema) + , genValue ranges (set schemaType (Just $ SingleType t') schema) + ] + Just (MultipleTypes (t :| (t':ts))) -> + Gen.choice + [ genValue ranges (set schemaType (Just $ SingleType t) schema) + , genValue ranges (set schemaType (Just $ MultipleTypes (t' :| ts)) schema) + ] + Just (SingleType NullType) -> genNullValue + Just (SingleType BooleanType) -> genBooleanValue + Just (SingleType NumberType) -> genNumberValue (ranges ^. numberRange) schema + Just (SingleType IntegerType) -> genIntegerValue (ranges ^. integerRange) schema + Just (SingleType StringType) -> genStringValue (ranges ^. stringRange) schema + Just (SingleType ObjectType) -> genObjectValue ranges schema + Just (SingleType ArrayType) -> genArrayValue ranges schema + +genNullValue :: Gen Aeson.Value +genNullValue = Gen.constant Aeson.Null + +genBooleanValue :: Gen Aeson.Value +genBooleanValue = Aeson.Bool <$> Gen.bool + +genNumberValue :: NumberRange -> Schema -> Gen Aeson.Value +genNumberValue (NumberRange nr) schema = + (Aeson.Number . Scientific.fromFloatDigits) <$> + genBoundedReal + (schema ^. schemaExclusiveMinimum) + (schema ^. schemaMinimum) + (schema ^. schemaExclusiveMaximum) + (schema ^. schemaMaximum) + nr + +genIntegerValue :: IntegerRange -> Schema -> Gen Aeson.Value +genIntegerValue (IntegerRange nr) schema = + (Aeson.Number . fromInteger) <$> + genBoundedInteger + (schema ^. schemaExclusiveMinimum) + (schema ^. schemaMinimum) + (schema ^. schemaExclusiveMaximum) + (schema ^. schemaMaximum) + (schema ^. schemaMultipleOf) + nr + +genStringValue :: StringRange -> Schema -> Gen Aeson.Value +genStringValue (StringRange sr) schema = + case schema ^. schemaPattern of + Just (StringConstraintPattern regexp) -> Aeson.String <$> genStringFromRegexp regexp + Nothing -> Aeson.String <$> genBoundedString (schema ^. schemaMinLength) (schema ^. schemaMaxLength) sr + +genObjectValue :: Ranges -> Schema -> Gen Aeson.Value +genObjectValue ranges schema = (Aeson.Object . HashMap.fromList . join) <$> generatedFields + where + generatedFields = traverse (\(n, gen) -> (\m -> (\v -> (n, v)) <$> (maybeToList m)) <$> gen) generatedFieldsMaybes + generatedFieldsMaybes = + (\(n, s) -> + ( n + , (if n `elem` required + then fmap Just + else Gen.maybe) + (Gen.small $ genValue ranges s))) <$> + HashMap.toList properties + required = maybe [] unObjectConstraintRequired (schema ^. schemaRequired) + properties = maybe HashMap.empty unObjectConstraintProperties (schema ^. schemaProperties) + +genArrayValue :: Ranges -> Schema -> Gen Aeson.Value +genArrayValue ranges schema = + case unArrayConstraintItems <$> (schema ^. schemaItems) of + Just itemSchema -> + Gen.sized $ \sz -> + (Aeson.Array . Vector.fromList) <$> + let listMaker = + if uniqueItems + then genUniqueItems + else Gen.list + in listMaker (finalRange sz) (Gen.small $ genValue ranges itemSchema) + Nothing -> Unconstrained.genArray ranges + where + ar = unArrayRange (ranges ^. arrayRange) + finalRange sz = + Range.linear (fromMaybe (Range.lowerBound sz ar) minItems) (fromMaybe (Range.upperBound sz ar) maxItems) + uniqueItems = maybe False unArrayConstraintUniqueItems (schema ^. schemaUniqueItems) + maxItems = unArrayConstraintMaxItems <$> (schema ^. schemaMaxItems) + minItems = unArrayConstraintMinItems <$> (schema ^. schemaMinItems) diff --git a/src/Hedgehog/Gen/JSON/Constrained/Internal.hs b/src/Hedgehog/Gen/JSON/Constrained/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Gen/JSON/Constrained/Internal.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hedgehog.Gen.JSON.Constrained.Internal + ( genBoundedInteger + , genBoundedReal + , genBoundedString + , genStringFromRegexp + , genUniqueItems + , filterAll + , filterAllMaybe + ) where + +import qualified Data.HashSet as HashSet +import Data.Scientific (Scientific) +import qualified Data.Scientific as Scientific +import qualified Data.Text as Text +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen.JSON.JSONSchema +import qualified Hedgehog.Range as Range +import Protolude +import qualified Regex.Genex as Genex + +-- | Generates an Integer bounded by the given constraints or by the given range, as well as a multiple-of constraint. +genBoundedInteger :: + Maybe NumberConstraintExclusiveMinimum + -> Maybe NumberConstraintMinimum + -> Maybe NumberConstraintExclusiveMaximum + -> Maybe NumberConstraintMaximum + -> Maybe NumberConstraintMultipleOf + -> Range Integer + -> Gen Integer +genBoundedInteger cminEx cmin cmaxEx cmax cmult range = + Gen.sized $ \sz -> filterAllMaybe filters $ Gen.integral (finalRange sz) + where + filters = [minExFilter, maxExFilter, minFilter, maxFilter, multipleOfFilter] + minExFilter = ((\b -> (> b)) . truncateScientific . unNumberConstraintExclusiveMinimum) <$> cminEx + minFilter = ((\b -> (>= b)) . truncateScientific . unNumberConstraintMinimum) <$> cmin + maxExFilter = ((\b -> (< b)) . truncateScientific . unNumberConstraintExclusiveMaximum) <$> cmaxEx + maxFilter = ((\b -> (<= b)) . truncateScientific . unNumberConstraintMaximum) <$> cmax + multipleOfFilter = ((\m x -> (x `rem` m == 0)) . truncateScientific . unNumberConstraintMultipleOf) <$> cmult + finalRange sz = Range.linear (minB sz) (maxB sz) + minB sz = + fromMaybe + (Range.lowerBound sz range) + ((maximumMay . catMaybes) + [ (truncateScientific . unNumberConstraintMinimum) <$> cmin + , (truncateScientific . unNumberConstraintExclusiveMinimum) <$> cminEx + ]) + maxB sz = + fromMaybe + (Range.lowerBound sz range) + ((minimumMay . catMaybes) + [ (truncateScientific . unNumberConstraintMaximum) <$> cmax + , (truncateScientific . unNumberConstraintExclusiveMaximum) <$> cmaxEx + ]) + +-- | Generates a Double bounded by the given constraints or by the given range. +genBoundedReal :: + Maybe NumberConstraintExclusiveMinimum + -> Maybe NumberConstraintMinimum + -> Maybe NumberConstraintExclusiveMaximum + -> Maybe NumberConstraintMaximum + -> Range Double + -> Gen Double +genBoundedReal cminEx cmin cmaxEx cmax range = Gen.sized $ \sz -> filterAllMaybe filters $ Gen.realFloat (finalRange sz) + where + filters = [minExFilter, maxExFilter, minFilter, maxFilter] + minExFilter = ((\b -> (> b)) . Scientific.toRealFloat . unNumberConstraintExclusiveMinimum) <$> cminEx + minFilter = ((\b -> (>= b)) . Scientific.toRealFloat . unNumberConstraintMinimum) <$> cmin + maxExFilter = ((\b -> (< b)) . Scientific.toRealFloat . unNumberConstraintExclusiveMaximum) <$> cmaxEx + maxFilter = ((\b -> (<= b)) . Scientific.toRealFloat . unNumberConstraintMaximum) <$> cmax + finalRange sz = Range.linearFrac (minB sz) (maxB sz) + minB sz = + fromMaybe + (Range.lowerBound sz range) + ((maximumMay . catMaybes) + [ (Scientific.toRealFloat . unNumberConstraintMinimum) <$> cmin + , (Scientific.toRealFloat . unNumberConstraintExclusiveMinimum) <$> cminEx + ]) + maxB sz = + fromMaybe + (Range.lowerBound sz range) + ((minimumMay . catMaybes) + [ (Scientific.toRealFloat . unNumberConstraintMaximum) <$> cmax + , (Scientific.toRealFloat . unNumberConstraintExclusiveMaximum) <$> cmaxEx + ]) + +-- | Generates a Text bounded in size by the given constraints or by the given range. +genBoundedString :: Maybe StringConstraintMinLength -> Maybe StringConstraintMaxLength -> Range Int -> Gen Text +genBoundedString minLengthC maxLengthC range = + Gen.sized $ \size -> filterAllMaybe filters $ Gen.text (Range.linear (minB size) (maxB size)) Gen.unicode + where + minB sz = maybe (Range.lowerBound sz range) unStringConstraintMinLength minLengthC + maxB sz = maybe (Range.upperBound sz range) unStringConstraintMaxLength maxLengthC + filters = + [ ((\b t -> Text.length t >= b) . unStringConstraintMinLength) <$> minLengthC + , ((\b t -> Text.length t <= b) . unStringConstraintMaxLength) <$> maxLengthC + ] + +-- | Generates a Text from a given Regular Expression +genStringFromRegexp :: Text -> Gen Text +genStringFromRegexp regexp = Gen.element $ Text.pack <$> take 10 (Genex.genexPure [Text.unpack regexp]) + +-- | Generates unique lists of the given generator and a size range +genUniqueItems :: (Hashable a, Eq a) => Range Int -> Gen a -> Gen [a] +genUniqueItems = genUniqueItems' 100 [] + +-- Gives up after 100 trials +genUniqueItems' :: (Hashable a, Eq a) => Int -> [a] -> Range Int -> Gen a -> Gen [a] +genUniqueItems' s acc range gen + | s == 0 = Gen.discard + | otherwise = + Gen.sized $ \size -> do + initialList <- (makeListUnique . (++ acc)) <$> Gen.list range gen + let l = length initialList + if Range.lowerBound size range <= l + then pure initialList + else take (Range.upperBound size range) <$> genUniqueItems' (s - 1) initialList range gen + +-- | Filters out values that do not satisfy all the given predicates each +filterAll :: [a -> Bool] -> Gen a -> Gen a +filterAll filters = Gen.filter (\e -> and (($ e) <$> filters)) + +-- | Filters out values that do not satisfy all the given not-Nothing predicates +filterAllMaybe :: [Maybe (a -> Bool)] -> Gen a -> Gen a +filterAllMaybe filters = filterAll (catMaybes filters) + +--- Helpers ---- +truncateScientific :: Integral a => Scientific -> a +truncateScientific x = truncate real + where + real :: Double = Scientific.toRealFloat x + +makeListUnique :: (Eq a, Hashable a) => [a] -> [a] +makeListUnique = toList . HashSet.fromList diff --git a/src/Hedgehog/Gen/JSON/JSONSchema.hs b/src/Hedgehog/Gen/JSON/JSONSchema.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Gen/JSON/JSONSchema.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Hedgehog.Gen.JSON.JSONSchema where + +import Control.Lens (makeLenses) +import Control.Monad.Fail +import Data.Aeson (withObject, (.:?)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NonEmpty +import Data.Scientific (Scientific) +import qualified Data.Text as Text +import Protolude + +data PrimitiveType + = NullType + | BooleanType + | ObjectType + | ArrayType + | NumberType + | StringType + | IntegerType + deriving (Show, Eq, Ord, Enum, Bounded) + +instance Aeson.FromJSON PrimitiveType where + parseJSON (Aeson.String t) = + case Text.toLower t of + "null" -> pure NullType + "bool" -> pure BooleanType + "array" -> pure ArrayType + "integer" -> pure IntegerType + "number" -> pure NumberType + "string" -> pure StringType + "object" -> pure ObjectType + _ -> fail "Primitive type is not one of (null, bool, array, number, string)" + parseJSON _ = fail "type is not a JSON String" + +data AnyConstraintType + = SingleType PrimitiveType + | MultipleTypes (NonEmpty PrimitiveType) + deriving (Eq, Show) + +instance Aeson.FromJSON AnyConstraintType where + parseJSON str@(Aeson.String _) = SingleType <$> Aeson.parseJSON str + parseJSON (Aeson.Array ts) = (MultipleTypes . NonEmpty.fromList . toList) <$> traverse Aeson.parseJSON ts + parseJSON _ = fail "type must be either a string or an array of strings" + +newtype AnyConstraintEnum = AnyConstraintEnum + { unArrayConstraintEnum :: NonEmpty Aeson.Value + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype AnyConstraintConst = AnyConstraintConst + { unArrayConstraintConst :: Aeson.Value + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype NumberConstraintMultipleOf = NumberConstraintMultipleOf + { unNumberConstraintMultipleOf :: Scientific + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype NumberConstraintMaximum = NumberConstraintMaximum + { unNumberConstraintMaximum :: Scientific + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype NumberConstraintExclusiveMaximum = NumberConstraintExclusiveMaximum + { unNumberConstraintExclusiveMaximum :: Scientific + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype NumberConstraintMinimum = NumberConstraintMinimum + { unNumberConstraintMinimum :: Scientific + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype NumberConstraintExclusiveMinimum = NumberConstraintExclusiveMinimum + { unNumberConstraintExclusiveMinimum :: Scientific + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype StringConstraintPattern = StringConstraintPattern + { unStringConstraintPattern :: Text + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype StringConstraintMaxLength = StringConstraintMaxLength + { unStringConstraintMaxLength :: Int + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype StringConstraintMinLength = StringConstraintMinLength + { unStringConstraintMinLength :: Int + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +instance Aeson.FromJSON Schema where + parseJSON = + withObject "Schema" $ \obj -> + Schema <$> obj .:? "type" <*> obj .:? "enum" <*> obj .:? "const" <*> obj .:? "properties" <*> obj .:? "required" <*> + obj .:? "multipleOf" <*> + obj .:? "maximum" <*> + obj .:? "exclusiveMaximum" <*> + obj .:? "minimum" <*> + obj .:? "exclusiveMinimum" <*> + obj .:? "pattern" <*> + obj .:? "maxLength" <*> + obj .:? "minLength" <*> + obj .:? "items" <*> + obj .:? "maxItems" <*> + obj .:? "minItems" <*> + obj .:? "uniqueItems" + +newtype ObjectConstraintProperties = ObjectConstraintProperties + { unObjectConstraintProperties :: HM.HashMap Text Schema + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype ObjectConstraintRequired = ObjectConstraintRequired + { unObjectConstraintRequired :: [Text] + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype ArrayConstraintItems = ArrayConstraintItems + { unArrayConstraintItems :: Schema + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype ArrayConstraintMaxItems = ArrayConstraintMaxItems + { unArrayConstraintMaxItems :: Int + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype ArrayConstraintMinItems = ArrayConstraintMinItems + { unArrayConstraintMinItems :: Int + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype ArrayConstraintUniqueItems = ArrayConstraintUniqueItems + { unArrayConstraintUniqueItems :: Bool + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +data Schema = Schema + { _schemaType :: Maybe AnyConstraintType + , _schemaEnum :: Maybe AnyConstraintEnum + , _schemaConst :: Maybe AnyConstraintConst + , _schemaProperties :: Maybe ObjectConstraintProperties + , _schemaRequired :: Maybe ObjectConstraintRequired + , _schemaMultipleOf :: Maybe NumberConstraintMultipleOf + , _schemaMaximum :: Maybe NumberConstraintMaximum + , _schemaExclusiveMaximum :: Maybe NumberConstraintExclusiveMaximum + , _schemaMinimum :: Maybe NumberConstraintMinimum + , _schemaExclusiveMinimum :: Maybe NumberConstraintExclusiveMinimum + , _schemaPattern :: Maybe StringConstraintPattern + , _schemaMaxLength :: Maybe StringConstraintMaxLength + , _schemaMinLength :: Maybe StringConstraintMinLength + , _schemaItems :: Maybe ArrayConstraintItems + , _schemaMaxItems :: Maybe ArrayConstraintMaxItems + , _schemaMinItems :: Maybe ArrayConstraintMinItems + , _schemaUniqueItems :: Maybe ArrayConstraintUniqueItems + } deriving (Generic, Eq, Show) + +emptySchema :: Schema +emptySchema = + Schema + { _schemaType = Nothing + , _schemaEnum = Nothing + , _schemaConst = Nothing + , _schemaRequired = Nothing + , _schemaProperties = Nothing + , _schemaMultipleOf = Nothing + , _schemaMaximum = Nothing + , _schemaMinimum = Nothing + , _schemaExclusiveMaximum = Nothing + , _schemaExclusiveMinimum = Nothing + , _schemaPattern = Nothing + , _schemaMinLength = Nothing + , _schemaMaxLength = Nothing + , _schemaItems = Nothing + , _schemaMinItems = Nothing + , _schemaMaxItems = Nothing + , _schemaUniqueItems = Nothing + } + +makeLenses ''Schema + +read :: FilePath -> IO (Either Text Schema) +read fp = do + bytes <- BS.readFile fp + pure $ maybeToEither "failed to decode JSON Schema" (Aeson.decodeStrict bytes) diff --git a/src/Hedgehog/Gen/JSON/Ranges.hs b/src/Hedgehog/Gen/JSON/Ranges.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Gen/JSON/Ranges.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Hedgehog.Gen.JSON.Ranges where + +import Control.Lens +import Hedgehog + +newtype NumberRange = NumberRange + { unNumberRange :: Range Double + } + +newtype IntegerRange = IntegerRange + { unIntegerRange :: Range Integer + } + +newtype StringRange = StringRange + { unStringRange :: Range Int + } + +newtype ArrayRange = ArrayRange + { unArrayRange :: Range Int + } + +newtype ObjectRange = ObjectRange + { unObjectRange :: Range Int + } + +data Ranges = Ranges + { _numberRange :: NumberRange + , _integerRange :: IntegerRange + , _stringRange :: StringRange + , _arrayRange :: ArrayRange + , _objectRange :: ObjectRange + } + +makeLenses ''Ranges diff --git a/src/Hedgehog/Gen/JSON/Unconstrained.hs b/src/Hedgehog/Gen/JSON/Unconstrained.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Gen/JSON/Unconstrained.hs @@ -0,0 +1,47 @@ +module Hedgehog.Gen.JSON.Unconstrained where + +import Control.Lens +import qualified Data.Aeson as A +import qualified Data.Scientific as Scientific +import qualified Data.Vector as Vector +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen.JSON.Ranges + +genNull :: Gen A.Value +genNull = pure A.Null + +genStringValue :: StringRange -> Gen A.Value +genStringValue (StringRange sr) = A.String <$> Gen.text sr Gen.unicode + +genBool :: Gen A.Value +genBool = A.Bool <$> Gen.bool + +genNumber :: NumberRange -> Gen A.Value +genNumber (NumberRange nr) = (A.Number . Scientific.fromFloatDigits) <$> Gen.double nr + +genArray :: Ranges -> Gen A.Value +genArray ranges = do + let gen = Gen.recursive Gen.choice [genBool, genNumber nr, genStringValue sr] [genArray ranges, genObj ranges] + (A.Array . Vector.fromList) <$> Gen.list ar gen + where + nr = ranges ^. numberRange + sr = ranges ^. stringRange + ArrayRange ar = ranges ^. arrayRange + +genObj :: Ranges -> Gen A.Value +genObj ranges = A.object <$> Gen.list ar ((,) <$> Gen.text sr Gen.unicode <*> genValue ranges) + where + (StringRange sr) = ranges ^. stringRange + (ArrayRange ar) = ranges ^. arrayRange + +genValue :: Ranges -> Gen A.Value +genValue ranges = + Gen.choice + [ genNull + , genStringValue (ranges ^. stringRange) + , genBool + , genNumber (ranges ^. numberRange) + , genArray ranges + , genObj ranges + ] diff --git a/test/Hedgehog/Gen/JSON/Constrained/Internal/InternalSpec.hs b/test/Hedgehog/Gen/JSON/Constrained/Internal/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hedgehog/Gen/JSON/Constrained/Internal/InternalSpec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hedgehog.Gen.JSON.Constrained.Internal.InternalSpec + ( tests + ) where + +import qualified Data.HashSet as HashSet +import qualified Data.Scientific as Scientific +import qualified Data.Text as Text +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen.JSON.Constrained.Internal +import Hedgehog.Gen.JSON.JSONSchema +import qualified Hedgehog.Range as Range +import Protolude +import Test.Tasty +import Test.Tasty.Hedgehog +import Text.Regex.Posix + +prop_genBoundedInteger :: Property +prop_genBoundedInteger = + property $ do + minC <- forAll $ Gen.maybe $ Gen.integral (Range.linear (-500) 500) + maxC <- forAll $ Gen.maybe $ Gen.integral (Range.linear 500 1500) + minExC <- forAll $ Gen.maybe $ Gen.integral (Range.linear (-500) 500) + maxExC <- forAll $ Gen.maybe $ Gen.integral (Range.linear 500 1500) + multC <- forAll $ Gen.maybe $ Gen.integral (Range.linear 1 10) + v <- + forAll $ + genBoundedInteger + ((NumberConstraintExclusiveMinimum . fromInteger) <$> minExC) + ((NumberConstraintMinimum . fromInteger) <$> minC) + ((NumberConstraintExclusiveMaximum . fromInteger) <$> maxExC) + ((NumberConstraintMaximum . fromInteger) <$> maxC) + ((NumberConstraintMultipleOf . fromInteger) <$> multC) + (Range.linear (-5000) 5000) + assert $ maybe True (v >=) minC + assert $ maybe True (v <=) maxC + assert $ maybe True (v >) minExC + assert $ maybe True (v <) maxExC + assert $ maybe True (\m -> v `rem` m == 0) multC + +prop_genBoundedReal :: Property +prop_genBoundedReal = + property $ do + minC <- forAll $ Gen.maybe $ Gen.double (Range.linearFrac (-500) 500) + maxC <- forAll $ Gen.maybe $ Gen.double (Range.linearFrac 500 1500) + minExC <- forAll $ Gen.maybe $ Gen.double (Range.linearFrac (-500) 500) + maxExC <- forAll $ Gen.maybe $ Gen.double (Range.linearFrac 500 1500) + v <- + forAll $ + genBoundedReal + ((NumberConstraintExclusiveMinimum . Scientific.fromFloatDigits) <$> minExC) + ((NumberConstraintMinimum . Scientific.fromFloatDigits) <$> minC) + ((NumberConstraintExclusiveMaximum . Scientific.fromFloatDigits) <$> maxExC) + ((NumberConstraintMaximum . Scientific.fromFloatDigits) <$> maxC) + (Range.linearFrac (-5000) 5000) + assert $ maybe True (v >=) minC + assert $ maybe True (v <=) maxC + assert $ maybe True (v >) minExC + assert $ maybe True (v <) maxExC + +prop_genBoundedString :: Property +prop_genBoundedString = + property $ do + minLengthC <- forAll $ Gen.maybe $ Gen.int (Range.linear 0 100) + maxLengthC <- forAll $ Gen.maybe $ Gen.int (Range.linear 100 200) + v <- + forAll $ + genBoundedString + ((StringConstraintMinLength . fromIntegral) <$> minLengthC) + ((StringConstraintMaxLength . fromIntegral) <$> maxLengthC) + (Range.linear 0 500) + assert $ maybe True (\n -> Text.length v >= n) minLengthC + assert $ maybe True (\n -> Text.length v <= n) maxLengthC + +prop_genStringFromRegexp :: Property +prop_genStringFromRegexp = + property $ do + let regexp = "[a-zA-Z0-9]{3,9}" + v <- forAll $ genStringFromRegexp regexp + assert $ Text.unpack v =~ Text.unpack regexp + +prop_genUniqueItems :: Property +prop_genUniqueItems = property $ do + let gen = Gen.int (Range.linear 0 1000) + generated <- forAll $ genUniqueItems (Range.linear 10 50) gen + assert $ length generated <= 50 + assert $ length generated >= 10 + (length . HashSet.fromList) generated === length generated + +tests :: TestTree +tests = + testGroup + "Constrained.Internal" + [ testProperty "Generates a bounded integer" prop_genBoundedInteger + , testProperty "Generates a bounded real" prop_genBoundedReal + , testProperty "Generates a bounded string" prop_genBoundedString + , testProperty "Generates a string from a regexp" prop_genStringFromRegexp + , testProperty "Generates a list of unique items" prop_genUniqueItems + ] diff --git a/test/Hedgehog/Gen/JSON/JSONSpec.hs b/test/Hedgehog/Gen/JSON/JSONSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hedgehog/Gen/JSON/JSONSpec.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hedgehog.Gen.JSON.JSONSpec + ( tests + ) where + +import Control.Lens (over, set) +import qualified Data.Aeson as Aeson +import Data.Fixed (mod') +import qualified Data.HashMap.Strict as H +import qualified Data.HashSet as HS +import qualified Data.Scientific as Scientific +import qualified Data.Text as Text +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen.JSON +import Hedgehog.Gen.JSON.JSONSchema +import qualified Hedgehog.Range as Range +import qualified Prelude as P +import Protolude +import Test.Tasty +import Test.Tasty.Hedgehog +import Text.Regex.Posix + +prop_generatedUnconstrainedJSON :: Property +prop_generatedUnconstrainedJSON = + property $ do + v <- forAll $ genJSON sensibleRanges + assert $ isJust (Aeson.decodeStrict v :: Maybe Aeson.Value) + +prop_constrainedValueFromEnum :: Property +prop_constrainedValueFromEnum = + property $ do + values <- forAll $ Gen.nonEmpty (Range.linear 1 10) (Gen.text (Range.linear 1 100) Gen.unicode) + schema <- forAll $ over schemaEnum (const $ Just $ AnyConstraintEnum (Aeson.String <$> values)) <$> genSchema + v <- forAll $ genConstrainedJSON sensibleRanges schema + assert $ isJust $ find (== Aeson.decodeStrict v) (Just <$> values) + +prop_constrainedValueFromConst :: Property +prop_constrainedValueFromConst = + property $ do + c <- forAll $ genJSONValue sensibleRanges + schema <- forAll $ over schemaConst (const $ Just $ AnyConstraintConst c) <$> genSchema + v <- forAll $ genConstrainedJSON sensibleRanges schema + Aeson.decodeStrict v === Just c + +prop_constrainedNumber :: Property +prop_constrainedNumber = + property $ do + vmin <- forAll $ Gen.maybe $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 0 5000) + vminEx <- forAll $ Gen.maybe $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 0 5000) + vmax <- forAll $ Gen.maybe $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 6000 10000) + vmaxEx <- forAll $ Gen.maybe $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 6000 10000) + let schema = + (set schemaMinimum (NumberConstraintMinimum <$> vmin) . + set schemaMaximum (NumberConstraintMaximum <$> vmax) . + set schemaExclusiveMinimum (NumberConstraintExclusiveMinimum <$> vminEx) . + set schemaExclusiveMaximum (NumberConstraintExclusiveMaximum <$> vmaxEx)) + (singleTypeSchema NumberType) + (Aeson.Number v) <- forAll $ genConstrainedJSONValue sensibleRanges schema + assert $ maybe True (v >=) vmin + assert $ maybe True (v <=) vmax + assert $ maybe True (v <) vmaxEx + assert $ maybe True (v >) vminEx + +prop_constrainedInteger :: Property +prop_constrainedInteger = + property $ do + vmin <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear (-50) 50) + vminEx <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear (-50) 50) + vmax <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear 50 100) + vmaxEx <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear 50 100) + multipleOf <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear 1 10) + let schema = + (set schemaMinimum (NumberConstraintMinimum <$> vmin) . + set schemaMaximum (NumberConstraintMaximum <$> vmax) . + set schemaExclusiveMinimum (NumberConstraintExclusiveMinimum <$> vminEx) . + set schemaExclusiveMaximum (NumberConstraintExclusiveMaximum <$> vmaxEx) . + set schemaMultipleOf (NumberConstraintMultipleOf <$> multipleOf)) + (singleTypeSchema IntegerType) + (Aeson.Number v) <- forAll $ genConstrainedJSONValue sensibleRanges schema + assert $ maybe True (v >=) vmin + assert $ maybe True (v <=) vmax + assert $ maybe True (v <) vmaxEx + assert $ maybe True (v >) vminEx + assert $ maybe True (\x -> v `mod'` x == 0) multipleOf + assert $ Scientific.isInteger v + +prop_constrainedString :: Property +prop_constrainedString = + property $ do + minLength <- forAll $ Gen.maybe $ Gen.integral (Range.linear 0 50) + maxLength <- forAll $ Gen.maybe $ Gen.integral (Range.linear 50 100) + regexp <- forAll $ Gen.maybe $ Gen.constant "[a-zA-Z0-9]{3,9}" -- Not very arbitrary, I know. + let schema = + (set schemaPattern (StringConstraintPattern <$> regexp) . + set schemaMinLength (StringConstraintMinLength <$> minLength) . + set schemaMaxLength (StringConstraintMaxLength <$> maxLength)) + (singleTypeSchema StringType) + (Aeson.String v) <- forAll $ genConstrainedJSONValue sensibleRanges schema + assert $ + case regexp of + Just p -> Text.unpack v =~ Text.unpack p + Nothing -> Text.length v >= fromMaybe 0 minLength && Text.length v <= fromMaybe 1000 maxLength + +prop_constrainedObject :: Property +prop_constrainedObject = + property $ do + nonRequiredFields <- + forAll $ + H.fromList <$> (Gen.list (Range.linear 1 10) $ ((,) <$> (Gen.text (Range.linear 1 10) Gen.unicode) <*> genSchema)) + requiredFields <- + forAll $ + H.fromList <$> (Gen.list (Range.linear 1 10) $ ((,) <$> (Gen.text (Range.linear 1 10) Gen.unicode) <*> genSchema)) + let schema = + (set schemaProperties (Just $ ObjectConstraintProperties (nonRequiredFields `H.union` requiredFields)) . + set schemaRequired (Just $ ObjectConstraintRequired $ H.keys requiredFields)) + (singleTypeSchema ObjectType) + (Aeson.Object v) <- forAll $ genConstrainedJSONValue sensibleRanges schema + assert $ all (`elem` (H.keys v)) (H.keys requiredFields) + +prop_constrainedArray :: Property +prop_constrainedArray = + property $ do + uniqueItems <- forAll $ Gen.maybe Gen.bool + minItems <- forAll $ Gen.maybe $ Gen.integral (Range.linear 0 2) + maxItems <- forAll $ Gen.maybe $ Gen.integral (Range.linear 3 5) + itemSchema <- forAll genSchema + let schema = + (set schemaMinItems (ArrayConstraintMinItems <$> minItems) . + set schemaMaxItems (ArrayConstraintMaxItems <$> maxItems) . + set schemaUniqueItems (ArrayConstraintUniqueItems <$> uniqueItems) . + set schemaItems (Just $ ArrayConstraintItems itemSchema)) + (singleTypeSchema ArrayType) + (Aeson.Array v) <- forAll $ genConstrainedJSONValue sensibleRanges schema + assert $ maybe True (length v >=) minItems + assert $ maybe True (length v <=) maxItems + assert $ + maybe + True + (\b -> + if b + then isUnique v + else True) + uniqueItems + +prop_decodesSchema :: Property +prop_decodesSchema = property $ decoded === Right expected + where + schemaJson = + "{\"type\":\"object\",\"properties\":{\"user_id\":{\"type\":\"integer\"},\"user_domain\":{\"type\":\"string\"}},\"required\":[\"user_id\"]}" + decoded :: Either P.String Schema = Aeson.eitherDecode schemaJson + expected = + (set schemaRequired (Just (ObjectConstraintRequired ["user_id"])) . + set + schemaProperties + ((Just . ObjectConstraintProperties) + (H.fromList [("user_id", singleTypeSchema IntegerType), ("user_domain", singleTypeSchema StringType)]))) + (singleTypeSchema ObjectType) + +genSchema :: Gen Schema +genSchema = do + t <- Gen.enumBounded + pure $ singleTypeSchema t + +singleTypeSchema :: PrimitiveType -> Schema +singleTypeSchema t = set schemaType (Just $ SingleType t) emptySchema + +isUnique :: (Hashable a, Eq a, Foldable t) => t a -> Bool +isUnique xs = (toList . HS.fromList . toList) xs == toList xs + +tests :: TestTree +tests = + testGroup + "Generated JSON" + [ testProperty "Generated unconstrained values are valid JSON" prop_generatedUnconstrainedJSON + , testProperty "Decodes JSON Schema" prop_decodesSchema + , testProperty "Generates constrained values from JSON Schema enum when present" prop_constrainedValueFromEnum + , testProperty "Generates constrained values from JSON Schema const when present" prop_constrainedValueFromConst + , testProperty "Generates a constrained number" prop_constrainedNumber + , testProperty "Generates a constrained integer" prop_constrainedInteger + , testProperty "Generates a constrained string" prop_constrainedString + , testProperty "Generates a constrained object" prop_constrainedObject + , testProperty "Generates a constrained array" prop_constrainedArray + ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,35 +1,16 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -import qualified Data.Aeson as Aeson -import Hedgehog -import Hedgehog.Gen.JSON -import qualified Hedgehog.Range as Range +module Main where + +import qualified Hedgehog.Gen.JSON.Constrained.Internal.InternalSpec as InternalSpec +import qualified Hedgehog.Gen.JSON.JSONSpec as JSONSpec import Protolude import Test.Tasty -import Test.Tasty.Hedgehog -ranges :: Ranges -ranges = - Ranges - { _arrayRange = ArrayRange {unArrayRange = (Range.linear 0 5)} - , _stringRange = StringRange {unStringRange = (Range.linear 0 100)} - , _numberRange = NumberRange {unNumberRange = (Range.linearFrac 0 1000)} - , _objectRange = ObjectRange {unObjectRange = (Range.linear 0 5)} - } - -prop_generatedUnconstrainedJSON :: Property -prop_generatedUnconstrainedJSON = - property $ do - v <- forAll $ genJSON ranges - assert $ isJust ((Aeson.decodeStrict v) :: Maybe Aeson.Value) - tests :: TestTree -tests = - testGroup - "Hedgehog.Gen.JSON tests" - [testProperty "Generated unconstrained values are valid JSON" prop_generatedUnconstrainedJSON] +tests = testGroup "Hedgehog.Gen.JSON tests" [InternalSpec.tests, JSONSpec.tests] main :: IO () main = defaultMain tests