hedgehog-gen-json 0.5.0 → 0.5.1
raw patch · 4 files changed
+196/−19 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- hedgehog-gen-json.cabal +2/−2
- src/Hedgehog/Gen/JSON/Constrained.hs +21/−2
- src/Hedgehog/Gen/JSON/JSONSchema.hs +148/−6
- test/Hedgehog/Gen/JSON/JSONSpec.hs +25/−9
hedgehog-gen-json.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: b6607e84b94f4b18937f5a00a356d91f02790f07d582597b20a9a8519d57bc96+-- hash: 80d356eb25a2c625e3539c65528672f6d4610a9065dd124e3de0678127451105 name: hedgehog-gen-json-version: 0.5.0+version: 0.5.1 synopsis: JSON generators for Hedgehog description: Generate JSON values for Hedgehog tests category: Test
src/Hedgehog/Gen/JSON/Constrained.hs view
@@ -29,7 +29,6 @@ genValue :: Ranges -> ToplevelSchema -> Schema -> Gen Aeson.Value genValue ranges tschema schema- | isJust (schema ^. schemaRef) = genReferencedSchema ranges tschema schema | isJust (schema ^. schemaAnyOf) = case schema ^. schemaAnyOf of Just (AnyConstraintAnyOf ss) -> Gen.element (toList ss) >>= genValue ranges tschema@@ -40,8 +39,12 @@ Nothing -> empty | isJust (schema ^. schemaAllOf) = case schema ^. schemaAllOf of- Just (AnyConstraintAllOf ss) -> Gen.element (toList ss) >>= genValue ranges tschema+ Just (AnyConstraintAllOf ss) -> do+ schemas <- traverse (genResolveIfReferencing tschema) ss+ combined <- eitherToGen $ foldl (\acc x -> acc >>= \a -> a *&* x) (Right emptySchema) schemas+ genValue ranges tschema combined Nothing -> empty+ | isJust (schema ^. schemaRef) = genReferencedSchema ranges tschema schema | isJust (schema ^. schemaEnum) = case schema ^. schemaEnum of Just (AnyConstraintEnum vs) -> (Gen.element . toList) vs@@ -107,6 +110,22 @@ genReferencedSchema ranges tschema schema = maybe (fail ("Referenced schema not found for " <> show schema)) (genValue ranges tschema) (ref >>= refSchema) where ref = (unAnyConstraintRef <$> (schema ^. schemaRef)) >>= Text.stripPrefix "#/definitions/" refSchema r = unAnyConstraintDefinitions <$> (unToplevelSchema tschema) ^. schemaDefinitions >>= HashMap.lookup r++resolveIfReferencing :: ToplevelSchema -> Schema -> Either Text Schema+resolveIfReferencing tschema schema =+ case schema ^. schemaRef of+ Just (AnyConstraintRef ref) -> maybeToEither ("Referenced schema not found for " <> show schema) ((Text.stripPrefix "#/definitions/" ref) >>= refSchema)+ Nothing -> Right schema+ where + refSchema :: Text -> Maybe Schema+ refSchema r = unAnyConstraintDefinitions <$> (unToplevelSchema tschema) ^. schemaDefinitions >>= HashMap.lookup r++genResolveIfReferencing :: ToplevelSchema -> Schema -> Gen Schema+genResolveIfReferencing tschema schema = eitherToGen $ resolveIfReferencing tschema schema++eitherToGen :: Either Text a -> Gen a+eitherToGen (Left err) = fail (toS err)+eitherToGen (Right x) = pure x genObjectValue :: Ranges -> ToplevelSchema -> Schema -> Gen Aeson.Value genObjectValue ranges tschema schema = (Aeson.Object . HashMap.fromList . join) <$> generatedFields
src/Hedgehog/Gen/JSON/JSONSchema.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-} module Hedgehog.Gen.JSON.JSONSchema where @@ -11,11 +12,16 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM+import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import Data.Scientific (Scientific)+import Data.Semigroup import qualified Data.Text as Text-import Protolude+import Protolude hiding ((<>)) +class CombineAnd a where+ (*&*) :: a -> a -> Either Text a+ data PrimitiveType = NullType | BooleanType@@ -44,6 +50,14 @@ | MultipleTypes (NonEmpty PrimitiveType) deriving (Eq, Show) +instance CombineAnd AnyConstraintType where+ (SingleType x) *&* (SingleType y) = MultipleTypes (NonEmpty.fromList [x]) *&* MultipleTypes (NonEmpty.fromList [y])+ (SingleType x) *&* (MultipleTypes ys) = MultipleTypes (NonEmpty.fromList [x]) *&* MultipleTypes ys+ (MultipleTypes xs) *&* (SingleType y) = MultipleTypes xs *&* MultipleTypes (NonEmpty.fromList [y])+ (MultipleTypes xs) *&* (MultipleTypes ys) =+ let zs = nonEmpty $ (toList xs) `List.intersect` (toList ys) in+ maybeToRight "Intersection of types is an empty list" (MultipleTypes <$> zs)+ 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@@ -53,50 +67,98 @@ { unArrayConstraintEnum :: NonEmpty Aeson.Value } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd AnyConstraintEnum where+ (AnyConstraintEnum x) *&* (AnyConstraintEnum y) =+ maybeToEither "intersection of `enum` is an empty list" (AnyConstraintEnum <$> nonEmpty (toList x `List.intersect` toList y))+ newtype AnyConstraintConst = AnyConstraintConst { unArrayConstraintConst :: Aeson.Value } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd AnyConstraintConst where+ (AnyConstraintConst x) *&* (AnyConstraintConst y)+ | x == y = Right (AnyConstraintConst x)+ | otherwise = Left "can't and-combine unequal `const`"+ newtype NumberConstraintMultipleOf = NumberConstraintMultipleOf { unNumberConstraintMultipleOf :: Scientific } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd NumberConstraintMultipleOf where+ (NumberConstraintMultipleOf x) *&* (NumberConstraintMultipleOf y) = Right $ NumberConstraintMultipleOf $ x * y+ newtype NumberConstraintMaximum = NumberConstraintMaximum { unNumberConstraintMaximum :: Scientific } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd NumberConstraintMaximum where+ (NumberConstraintMaximum x) *&* (NumberConstraintMaximum y) =+ Right $ NumberConstraintMaximum $ min x y+ newtype NumberConstraintExclusiveMaximum = NumberConstraintExclusiveMaximum { unNumberConstraintExclusiveMaximum :: Scientific } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd NumberConstraintExclusiveMaximum where+ (NumberConstraintExclusiveMaximum x) *&* (NumberConstraintExclusiveMaximum y) =+ Right $ NumberConstraintExclusiveMaximum $ min x y+ newtype NumberConstraintMinimum = NumberConstraintMinimum { unNumberConstraintMinimum :: Scientific } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd NumberConstraintMinimum where+ (NumberConstraintMinimum x) *&* (NumberConstraintMinimum y) =+ Right $ NumberConstraintMinimum $ max x y+ newtype NumberConstraintExclusiveMinimum = NumberConstraintExclusiveMinimum { unNumberConstraintExclusiveMinimum :: Scientific } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd NumberConstraintExclusiveMinimum where+ (NumberConstraintExclusiveMinimum x) *&* (NumberConstraintExclusiveMinimum y) =+ Right $ NumberConstraintExclusiveMinimum $ max x y+ newtype StringConstraintPattern = StringConstraintPattern { unStringConstraintPattern :: Text } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd StringConstraintPattern where+ _ *&* _ = Left "can't and-combine `pattern`"+ newtype StringConstraintFormat = StringConstraintFormat { unStringConstraintFormat :: Text } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd StringConstraintFormat where+ _ *&* _ = Left "can't and-combine `format`"+ newtype StringConstraintMaxLength = StringConstraintMaxLength { unStringConstraintMaxLength :: Int } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd StringConstraintMaxLength where+ (StringConstraintMaxLength x) *&* (StringConstraintMaxLength y) =+ Right $ StringConstraintMaxLength $ min x y+ newtype StringConstraintMinLength = StringConstraintMinLength { unStringConstraintMinLength :: Int } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd StringConstraintMinLength where+ (StringConstraintMinLength x) *&* (StringConstraintMinLength y) =+ Right $ StringConstraintMinLength $ min x y+ instance Aeson.FromJSON Schema where parseJSON = withObject "Schema" $ \obj ->- Schema <$> obj .:? "type" <*> obj .:? "enum" <*> obj .:? "const" <*> obj .:? "properties" <*> obj .:? "required" <*> obj .:? "multipleOf" <*>+ Schema <$>+ obj .:? "type" <*>+ obj .:? "enum" <*>+ obj .:? "const" <*>+ obj .:? "properties" <*>+ obj .:? "required" <*>+ obj .:? "multipleOf" <*> obj .:? "maximum" <*> obj .:? "exclusiveMaximum" <*> obj .:? "minimum" <*>@@ -115,54 +177,100 @@ obj .:? "oneOf" <*> obj .:? "allOf" -newtype ToplevelSchema = ToplevelSchema {- unToplevelSchema :: Schema-} deriving (Eq, Show, Generic, Aeson.FromJSON)+newtype ToplevelSchema = ToplevelSchema+ { unToplevelSchema :: Schema+ } deriving (Eq, Show, Generic, Aeson.FromJSON) newtype ObjectConstraintProperties = ObjectConstraintProperties { unObjectConstraintProperties :: HM.HashMap Text Schema } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd ObjectConstraintProperties where+ (ObjectConstraintProperties x) *&* (ObjectConstraintProperties y)+ | HM.null (x `HM.intersection` y) = Right $ ObjectConstraintProperties $ x <> y+ | otherwise = Left "can't and-combine overlapping properties"+ newtype ObjectConstraintRequired = ObjectConstraintRequired { unObjectConstraintRequired :: [Text] } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd ObjectConstraintRequired where+ (ObjectConstraintRequired x) *&* (ObjectConstraintRequired y) =+ Right $ ObjectConstraintRequired $ x <> y+ newtype AnyConstraintRef = AnyConstraintRef { unAnyConstraintRef :: Text } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd AnyConstraintRef where + _ *&* _ = Left "can't and-combine `$ref`"+ newtype AnyConstraintDefinitions = AnyConstraintDefinitions { unAnyConstraintDefinitions :: HM.HashMap Text Schema } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd AnyConstraintDefinitions where+ (AnyConstraintDefinitions x) *&* (AnyConstraintDefinitions y)+ | HM.null (x `HM.intersection` y) = Right $ AnyConstraintDefinitions $ x <> y+ | otherwise = Left "can't and-combine overlapping definitions"+ newtype AnyConstraintAllOf = AnyConstraintAllOf { unAnyConstraintAllOf :: NonEmpty Schema } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd AnyConstraintAllOf where+ (AnyConstraintAllOf x) *&* (AnyConstraintAllOf y) =+ Right $ AnyConstraintAllOf (x <> y)+ newtype AnyConstraintOneOf = AnyConstraintOneOf { unAnyConstraintOneOf :: NonEmpty Schema } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd AnyConstraintOneOf where+ (AnyConstraintOneOf x) *&* (AnyConstraintOneOf y) =+ maybeToEither "intersection of `oneOf` is an empty list" (AnyConstraintOneOf <$> nonEmpty (List.intersect (toList x) (toList y)))+ newtype AnyConstraintAnyOf = AnyConstraintAnyOf { unAnyConstraintAnyOf :: NonEmpty Schema } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd AnyConstraintAnyOf where+ (AnyConstraintAnyOf x) *&* (AnyConstraintAnyOf y) =+ maybeToEither "intersection of `anyOf` is an empty list" (AnyConstraintAnyOf <$> nonEmpty (List.intersect (toList x) (toList y)))+ newtype ArrayConstraintItems = ArrayConstraintItems { unArrayConstraintItems :: Schema } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd ArrayConstraintItems where+ (ArrayConstraintItems x) *&* (ArrayConstraintItems y) =+ ArrayConstraintItems <$> x *&* y+ newtype ArrayConstraintMaxItems = ArrayConstraintMaxItems { unArrayConstraintMaxItems :: Int } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd ArrayConstraintMaxItems where+ (ArrayConstraintMaxItems x) *&* (ArrayConstraintMaxItems y) =+ Right $ ArrayConstraintMaxItems $ min x y+ newtype ArrayConstraintMinItems = ArrayConstraintMinItems { unArrayConstraintMinItems :: Int } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd ArrayConstraintMinItems where+ (ArrayConstraintMinItems x) *&* (ArrayConstraintMinItems y) =+ Right $ ArrayConstraintMinItems $ max x y+ newtype ArrayConstraintUniqueItems = ArrayConstraintUniqueItems { unArrayConstraintUniqueItems :: Bool } deriving (Generic, Eq, Show, Aeson.FromJSON) +instance CombineAnd ArrayConstraintUniqueItems where+ (ArrayConstraintUniqueItems x) *&* (ArrayConstraintUniqueItems y)+ | x == y = Right $ ArrayConstraintUniqueItems x+ | otherwise = Left "can't and-combine different `unique` constraint"+ data Schema = Schema { _schemaType :: Maybe AnyConstraintType , _schemaEnum :: Maybe AnyConstraintEnum@@ -189,6 +297,41 @@ , _schemaAllOf :: Maybe AnyConstraintAllOf } deriving (Generic, Eq, Show) +makeLenses ''Schema++instance CombineAnd a => CombineAnd (Maybe a) where+ Nothing *&* Nothing = Right Nothing+ (Just x) *&* Nothing = Right $ Just x+ Nothing *&* (Just x) = Right $ Just x+ (Just x) *&* (Just y) = Just <$> x *&* y++instance CombineAnd Schema where+ x *&* y = Schema <$> + (_schemaType x *&* _schemaType y) <*>+ (_schemaEnum x *&* _schemaEnum y) <*>+ (_schemaConst x *&* _schemaConst y) <*>+ (_schemaProperties x *&* _schemaProperties y) <*>+ (_schemaRequired x *&* _schemaRequired y) <*>+ (_schemaMultipleOf x *&* _schemaMultipleOf y) <*>+ (_schemaMaximum x *&* _schemaMaximum y) <*>+ (_schemaExclusiveMaximum x *&* _schemaExclusiveMaximum y) <*>+ (_schemaMinimum x *&* _schemaMinimum y) <*>+ (_schemaExclusiveMinimum x *&* _schemaExclusiveMinimum y) <*>+ (_schemaPattern x *&* _schemaPattern y) <*>+ (_schemaFormat x *&* _schemaFormat y) <*>+ (_schemaMaxLength x *&* _schemaMaxLength y) <*>+ (_schemaMinLength x *&* _schemaMinLength y) <*>+ (_schemaItems x *&* _schemaItems y) <*>+ (_schemaMaxItems x *&* _schemaMaxItems y) <*>+ (_schemaMinItems x *&* _schemaMinItems y) <*>+ (_schemaUniqueItems x *&* _schemaUniqueItems y) <*>+ (_schemaRef x *&* _schemaRef y) <*>+ (_schemaDefinitions x *&* _schemaDefinitions y) <*>+ (_schemaAnyOf x *&* _schemaAnyOf y) <*>+ (_schemaOneOf x *&* _schemaOneOf y) <*>+ (_schemaAllOf x *&* _schemaAllOf y)++ emptySchema :: Schema emptySchema = Schema@@ -217,7 +360,6 @@ , _schemaAllOf = Nothing } -makeLenses ''Schema read :: FilePath -> IO (Either Text Schema) read fp = do
test/Hedgehog/Gen/JSON/JSONSpec.hs view
@@ -21,6 +21,7 @@ import Test.Tasty import Test.Tasty.Hedgehog import Text.Regex.PCRE+import qualified Data.List.NonEmpty as NonEmpty prop_generatedUnconstrainedJSON :: Property prop_generatedUnconstrainedJSON =@@ -142,16 +143,30 @@ prop_constrainedValueFromReferencedSchema :: Property prop_constrainedValueFromReferencedSchema = - property $ do- subSchema <- forAll genSchema- let schema = emptySchema { - _schemaType = Just $ SingleType ArrayType, - _schemaItems = Just $ ArrayConstraintItems $ emptySchema { _schemaRef = Just $ AnyConstraintRef "#/definitions/x" }, - _schemaDefinitions = Just $ AnyConstraintDefinitions $ H.fromList [("x", subSchema)]- }- _ <- forAll $ genConstrainedJSONValue sensibleRanges schema- success+ property $ do+ subSchema <- forAll genSchema+ let schema = emptySchema { + _schemaType = Just $ SingleType ArrayType, + _schemaItems = Just $ ArrayConstraintItems $ emptySchema { _schemaRef = Just $ AnyConstraintRef "#/definitions/x" }, + _schemaDefinitions = Just $ AnyConstraintDefinitions $ H.fromList [("x", subSchema)]+ }+ _ <- forAll $ genConstrainedJSONValue sensibleRanges schema+ success +prop_constrainedValueFromreferencedAllOfSchemas :: Property+prop_constrainedValueFromreferencedAllOfSchemas =+ property $ do+ x <- forAll $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 5 10)+ y <- forAll $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 20 30)+ let subschema1 = emptySchema { _schemaType = Just (SingleType IntegerType), _schemaMinimum = Just $ NumberConstraintMinimum x }+ let subschema2 = emptySchema { _schemaType = Just (SingleType IntegerType), _schemaMaximum = Just $ NumberConstraintMaximum y }+ let schema = emptySchema { + _schemaAllOf = Just $ AnyConstraintAllOf $ NonEmpty.fromList [ emptySchema { _schemaRef = Just (AnyConstraintRef "#/definitions/x") }, emptySchema { _schemaRef = Just (AnyConstraintRef "#/definitions/y") }],+ _schemaDefinitions = Just $ AnyConstraintDefinitions $ H.fromList [ ("x", subschema1), ("y", subschema2) ]+ }+ (Aeson.Number z) <- forAll $ genConstrainedJSONValue sensibleRanges schema+ assert $ (truncate z :: Int) >= (truncate x :: Int) && (truncate z :: Int) <= (truncate y :: Int)+ prop_decodesSchema :: Property prop_decodesSchema = property $ decoded === Right expected where@@ -204,4 +219,5 @@ , testProperty "Generates a constrained object" prop_constrainedObject , testProperty "Generates a constrained array" prop_constrainedArray , testProperty "Generates a value from a referenced schema" prop_constrainedValueFromReferencedSchema+ , testProperty "Generates a value from aggregated allOf referenced schemas" prop_constrainedValueFromreferencedAllOfSchemas ]