diff --git a/hedgehog-gen-json.cabal b/hedgehog-gen-json.cabal --- a/hedgehog-gen-json.cabal +++ b/hedgehog-gen-json.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: ddf576825a40f267efcc17461a489d807946f4f07d9029d265c9d07b3a2adf74 +-- hash: b22a7b9a7cb95c3f62c4308936bcc599b0cd199d24fa87256faf9f84595dcae6 name: hedgehog-gen-json -version: 0.3.0 +version: 0.4.0 synopsis: JSON generators for Hedgehog description: Generate JSON values for Hedgehog tests category: Test @@ -17,7 +17,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: README.md 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 @@ -57,7 +57,7 @@ -- | Generator for arbitrary JSON values constrained by the given JSON Schema genConstrainedJSONValue :: Ranges -> Schema -> Gen Aeson.Value -genConstrainedJSONValue = Constrained.genValue +genConstrainedJSONValue = Constrained.genToplevelValue -- | Sensible ranges for arbitrary JSON values if you're too lazy to define some sensibleRanges :: Ranges 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 @@ -2,14 +2,17 @@ {-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Gen.JSON.Constrained - ( genValue + ( genToplevelValue + , genValue , Schema ) where import Control.Lens +import Control.Monad import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap import qualified Data.Scientific as Scientific +import qualified Data.Text as Text import Data.Time.RFC3339 import qualified Data.Vector as Vector import Hedgehog @@ -21,8 +24,12 @@ import qualified Hedgehog.Range as Range import Protolude -genValue :: Ranges -> Schema -> Gen Aeson.Value -genValue ranges schema +genToplevelValue :: Ranges -> Schema -> Gen Aeson.Value +genToplevelValue ranges schema = genValue ranges (ToplevelSchema schema) schema + +genValue :: Ranges -> ToplevelSchema -> Schema -> Gen Aeson.Value +genValue ranges tschema schema + | isJust (schema ^. schemaRef) = genReferencedSchema ranges tschema schema | isJust (schema ^. schemaEnum) = case schema ^. schemaEnum of Just (AnyConstraintEnum vs) -> (Gen.element . toList) vs @@ -34,18 +41,18 @@ | otherwise = case schema ^. schemaType of Nothing -> Unconstrained.genValue ranges - Just (MultipleTypes (t :| [])) -> genValue ranges (set schemaType (Just $ SingleType t) schema) + Just (MultipleTypes (t :| [])) -> genValue ranges tschema (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)] + Gen.choice [genValue ranges tschema (set schemaType (Just $ SingleType t) schema), genValue ranges tschema (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)] + Gen.choice [genValue ranges tschema (set schemaType (Just $ SingleType t) schema), genValue ranges tschema (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 + Just (SingleType ObjectType) -> genObjectValue ranges tschema schema + Just (SingleType ArrayType) -> genArrayValue ranges tschema schema genNullValue :: Gen Aeson.Value genNullValue = Gen.constant Aeson.Null @@ -84,8 +91,13 @@ genWithFormat _ = genUnformatted genUnformatted = Aeson.String <$> genBoundedString (schema ^. schemaMinLength) (schema ^. schemaMaxLength) sr -genObjectValue :: Ranges -> Schema -> Gen Aeson.Value -genObjectValue ranges schema = (Aeson.Object . HashMap.fromList . join) <$> generatedFields +genReferencedSchema :: Ranges -> ToplevelSchema -> Schema -> Gen Aeson.Value +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 + +genObjectValue :: Ranges -> ToplevelSchema -> Schema -> Gen Aeson.Value +genObjectValue ranges tschema schema = (Aeson.Object . HashMap.fromList . join) <$> generatedFields where generatedFields = traverse (\(n, gen) -> (\m -> (\v -> (n, v)) <$> (maybeToList m)) <$> gen) generatedFieldsMaybes generatedFieldsMaybes = @@ -94,13 +106,13 @@ , (if n `elem` required then fmap Just else Gen.maybe) - (Gen.small $ genValue ranges s))) <$> + (Gen.small $ genValue ranges tschema 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 = +genArrayValue :: Ranges -> ToplevelSchema -> Schema -> Gen Aeson.Value +genArrayValue ranges tschema schema = case unArrayConstraintItems <$> (schema ^. schemaItems) of Just itemSchema -> Gen.sized $ \sz -> @@ -109,7 +121,7 @@ if uniqueItems then genUniqueItems else Gen.list - in listMaker (finalRange sz) (Gen.small $ genValue ranges itemSchema) + in listMaker (finalRange sz) (Gen.small $ genValue ranges tschema itemSchema) Nothing -> Unconstrained.genArray ranges where ar = unArrayRange (ranges ^. arrayRange) 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 @@ -108,8 +108,14 @@ obj .:? "items" <*> obj .:? "maxItems" <*> obj .:? "minItems" <*> - obj .:? "uniqueItems" + obj .:? "uniqueItems" <*> + obj .:? "$ref" <*> + obj .:? "definitions" +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) @@ -118,6 +124,14 @@ { unObjectConstraintRequired :: [Text] } deriving (Generic, Eq, Show, Aeson.FromJSON) +newtype AnyConstraintRef = AnyConstraintRef + { unAnyConstraintRef :: Text + } deriving (Generic, Eq, Show, Aeson.FromJSON) + +newtype AnyConstraintDefinitions = AnyConstraintDefinitions + { unAnyConstraintDefinitions :: HM.HashMap Text Schema + } deriving (Generic, Eq, Show, Aeson.FromJSON) + newtype ArrayConstraintItems = ArrayConstraintItems { unArrayConstraintItems :: Schema } deriving (Generic, Eq, Show, Aeson.FromJSON) @@ -153,6 +167,8 @@ , _schemaMaxItems :: Maybe ArrayConstraintMaxItems , _schemaMinItems :: Maybe ArrayConstraintMinItems , _schemaUniqueItems :: Maybe ArrayConstraintUniqueItems + , _schemaRef :: Maybe AnyConstraintRef + , _schemaDefinitions :: Maybe AnyConstraintDefinitions } deriving (Generic, Eq, Show) emptySchema :: Schema @@ -176,6 +192,8 @@ , _schemaMinItems = Nothing , _schemaMaxItems = Nothing , _schemaUniqueItems = Nothing + , _schemaRef = Nothing + , _schemaDefinitions = Nothing } makeLenses ''Schema 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 @@ -140,16 +140,27 @@ else True) uniqueItems +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 + 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\"]}" + schemaJson = "{\"type\":\"object\",\"properties\":{\"user_id\":{\"type\":\"integer\"},\"user_domain\":{\"type\":\"string\"}},\"required\":[\"user_id\"], \"definitions\": {\"positiveInteger\": { \"type\": \"integer\", \"exclusiveMinimum\": 0 }}}" 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)]))) + set schemaProperties ((Just . ObjectConstraintProperties) (H.fromList [("user_id", singleTypeSchema IntegerType), ("user_domain", singleTypeSchema StringType)])) . + set schemaDefinitions ((Just . AnyConstraintDefinitions) (H.fromList [("positiveInteger", (singleTypeSchema IntegerType) { _schemaExclusiveMinimum = Just (NumberConstraintExclusiveMinimum 0)})]))) (singleTypeSchema ObjectType) genSchema :: Gen Schema @@ -192,4 +203,5 @@ , testProperty "Generates a constrained string" prop_constrainedString , testProperty "Generates a constrained object" prop_constrainedObject , testProperty "Generates a constrained array" prop_constrainedArray + , testProperty "Generates a value from a referenced schema" prop_constrainedValueFromReferencedSchema ]