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: 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 diff --git a/src/Hedgehog/Gen/JSON/Constrained.hs b/src/Hedgehog/Gen/JSON/Constrained.hs --- a/src/Hedgehog/Gen/JSON/Constrained.hs +++ b/src/Hedgehog/Gen/JSON/Constrained.hs @@ -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 diff --git a/src/Hedgehog/Gen/JSON/JSONSchema.hs b/src/Hedgehog/Gen/JSON/JSONSchema.hs --- a/src/Hedgehog/Gen/JSON/JSONSchema.hs +++ b/src/Hedgehog/Gen/JSON/JSONSchema.hs @@ -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 diff --git a/test/Hedgehog/Gen/JSON/JSONSpec.hs b/test/Hedgehog/Gen/JSON/JSONSpec.hs --- a/test/Hedgehog/Gen/JSON/JSONSpec.hs +++ b/test/Hedgehog/Gen/JSON/JSONSpec.hs @@ -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 ]