diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,4 +2,4 @@ [![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). +Generators of arbitrary unconstrained or [JSON Schema](http://json-schema.org/) constrained values 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: 19509d71ae99a04870b3c2924858c720249638f0ff47c4c07a0545c172c51681 +-- hash: 86e9c2e335c348239ea9136832f4eab10451f7c07be61e2c2be13c9dfeb081c0 name: hedgehog-gen-json -version: 0.1.0 +version: 0.2.0 synopsis: JSON generators for Hedgehog description: Generate JSON values for Hedgehog tests category: Test @@ -24,7 +24,8 @@ library hs-source-dirs: src - ghc-options: -Wall + default-extensions: OverloadedStrings NoImplicitPrelude + ghc-options: -Wall -fhide-source-paths build-depends: aeson , base >=4.7 && <5 @@ -37,6 +38,9 @@ , regex-genex , scientific , text + , time + , timerep + , tz , unordered-containers , vector exposed-modules: @@ -56,7 +60,8 @@ hs-source-dirs: src test - ghc-options: -Wall + default-extensions: OverloadedStrings NoImplicitPrelude + ghc-options: -Wall -fhide-source-paths build-depends: aeson , base >=4.7 && <5 @@ -67,11 +72,14 @@ , lens , protolude , regex-genex - , regex-posix + , regex-pcre , scientific , tasty , tasty-hedgehog , text + , time + , timerep + , tz , unordered-containers , vector other-modules: 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 @@ -10,6 +10,7 @@ import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap import qualified Data.Scientific as Scientific +import Data.Time.RFC3339 import qualified Data.Vector as Vector import Hedgehog import qualified Hedgehog.Gen as Gen @@ -35,15 +36,9 @@ 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) - ] + 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) - ] + 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 @@ -61,12 +56,7 @@ genNumberValue :: NumberRange -> Schema -> Gen Aeson.Value genNumberValue (NumberRange nr) schema = (Aeson.Number . Scientific.fromFloatDigits) <$> - genBoundedReal - (schema ^. schemaExclusiveMinimum) - (schema ^. schemaMinimum) - (schema ^. schemaExclusiveMaximum) - (schema ^. schemaMaximum) - nr + genBoundedReal (schema ^. schemaExclusiveMinimum) (schema ^. schemaMinimum) (schema ^. schemaExclusiveMaximum) (schema ^. schemaMaximum) nr genIntegerValue :: IntegerRange -> Schema -> Gen Aeson.Value genIntegerValue (IntegerRange nr) schema = @@ -83,7 +73,16 @@ genStringValue (StringRange sr) schema = case schema ^. schemaPattern of Just (StringConstraintPattern regexp) -> Aeson.String <$> genStringFromRegexp regexp - Nothing -> Aeson.String <$> genBoundedString (schema ^. schemaMinLength) (schema ^. schemaMaxLength) sr + Nothing -> + case schema ^. schemaFormat of + Just (StringConstraintFormat f) -> genWithFormat f + Nothing -> genUnformatted + where + genWithFormat "uuid" = Aeson.String <$> genStringFromRegexp "[a-f0-9]{8}-[a-f0-9]{4}-4[a-f0-9]{3}-[89ab][a-f0-9]{3}-[a-f0-9]{12}" + genWithFormat "date-time" = (Aeson.String . formatTimeRFC3339) <$> genZonedTime (Range.linearFrac 0 999999999999999999) + genWithFormat "RFC 3339 date-time" = genWithFormat "date-time" + 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 @@ -110,12 +109,11 @@ if uniqueItems then genUniqueItems else Gen.list - in listMaker (finalRange sz) (Gen.small $ genValue ranges itemSchema) + 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) + 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 --- a/src/Hedgehog/Gen/JSON/Constrained/Internal.hs +++ b/src/Hedgehog/Gen/JSON/Constrained/Internal.hs @@ -6,6 +6,7 @@ , genBoundedReal , genBoundedString , genStringFromRegexp + , genZonedTime , genUniqueItems , filterAll , filterAllMaybe @@ -15,6 +16,11 @@ import Data.Scientific (Scientific) import qualified Data.Scientific as Scientific import qualified Data.Text as Text +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Time.LocalTime +import Data.Time.Zones +import Data.Time.Zones.All import Hedgehog import qualified Hedgehog.Gen as Gen import Hedgehog.Gen.JSON.JSONSchema @@ -31,8 +37,7 @@ -> Maybe NumberConstraintMultipleOf -> Range Integer -> Gen Integer -genBoundedInteger cminEx cmin cmaxEx cmax cmult range = - Gen.sized $ \sz -> filterAllMaybe filters $ Gen.integral (finalRange sz) +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 @@ -45,16 +50,12 @@ fromMaybe (Range.lowerBound sz range) ((maximumMay . catMaybes) - [ (truncateScientific . unNumberConstraintMinimum) <$> cmin - , (truncateScientific . unNumberConstraintExclusiveMinimum) <$> cminEx - ]) + [(truncateScientific . unNumberConstraintMinimum) <$> cmin, (truncateScientific . unNumberConstraintExclusiveMinimum) <$> cminEx]) maxB sz = fromMaybe (Range.lowerBound sz range) ((minimumMay . catMaybes) - [ (truncateScientific . unNumberConstraintMaximum) <$> cmax - , (truncateScientific . unNumberConstraintExclusiveMaximum) <$> cmaxEx - ]) + [(truncateScientific . unNumberConstraintMaximum) <$> cmax, (truncateScientific . unNumberConstraintExclusiveMaximum) <$> cmaxEx]) -- | Generates a Double bounded by the given constraints or by the given range. genBoundedReal :: @@ -76,28 +77,21 @@ fromMaybe (Range.lowerBound sz range) ((maximumMay . catMaybes) - [ (Scientific.toRealFloat . unNumberConstraintMinimum) <$> cmin - , (Scientific.toRealFloat . unNumberConstraintExclusiveMinimum) <$> cminEx - ]) + [(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 - ]) + [(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 +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 - ] + [((\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 @@ -135,3 +129,13 @@ makeListUnique :: (Eq a, Hashable a) => [a] -> [a] makeListUnique = toList . HashSet.fromList + +genZonedTime :: Range POSIXTime -> Gen ZonedTime +genZonedTime r = do + tz <- tzByLabel <$> Gen.enumBounded + t <- genUTCTime r + let timezone = timeZoneForUTCTime tz t + pure $ utcToZonedTime timezone t + +genUTCTime :: Range POSIXTime -> Gen UTCTime +genUTCTime r = posixSecondsToUTCTime <$> Gen.realFrac_ r 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 @@ -1,7 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -83,6 +81,10 @@ { unStringConstraintPattern :: Text } deriving (Generic, Eq, Show, Aeson.FromJSON) +newtype StringConstraintFormat = StringConstraintFormat + { unStringConstraintFormat :: Text + } deriving (Generic, Eq, Show, Aeson.FromJSON) + newtype StringConstraintMaxLength = StringConstraintMaxLength { unStringConstraintMaxLength :: Int } deriving (Generic, Eq, Show, Aeson.FromJSON) @@ -94,13 +96,13 @@ 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" <*> obj .:? "exclusiveMinimum" <*> obj .:? "pattern" <*> + obj .:? "format" <*> obj .:? "maxLength" <*> obj .:? "minLength" <*> obj .:? "items" <*> @@ -144,6 +146,7 @@ , _schemaMinimum :: Maybe NumberConstraintMinimum , _schemaExclusiveMinimum :: Maybe NumberConstraintExclusiveMinimum , _schemaPattern :: Maybe StringConstraintPattern + , _schemaFormat :: Maybe StringConstraintFormat , _schemaMaxLength :: Maybe StringConstraintMaxLength , _schemaMinLength :: Maybe StringConstraintMinLength , _schemaItems :: Maybe ArrayConstraintItems @@ -155,24 +158,25 @@ 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 - } + { _schemaType = Nothing + , _schemaEnum = Nothing + , _schemaConst = Nothing + , _schemaRequired = Nothing + , _schemaProperties = Nothing + , _schemaMultipleOf = Nothing + , _schemaMaximum = Nothing + , _schemaMinimum = Nothing + , _schemaExclusiveMaximum = Nothing + , _schemaExclusiveMinimum = Nothing + , _schemaPattern = Nothing + , _schemaFormat = Nothing + , _schemaMinLength = Nothing + , _schemaMaxLength = Nothing + , _schemaItems = Nothing + , _schemaMinItems = Nothing + , _schemaMaxItems = Nothing + , _schemaUniqueItems = Nothing + } makeLenses ''Schema diff --git a/src/Hedgehog/Gen/JSON/Ranges.hs b/src/Hedgehog/Gen/JSON/Ranges.hs --- a/src/Hedgehog/Gen/JSON/Ranges.hs +++ b/src/Hedgehog/Gen/JSON/Ranges.hs @@ -4,6 +4,7 @@ import Control.Lens import Hedgehog +import Protolude newtype NumberRange = NumberRange { unNumberRange :: Range Double diff --git a/src/Hedgehog/Gen/JSON/Unconstrained.hs b/src/Hedgehog/Gen/JSON/Unconstrained.hs --- a/src/Hedgehog/Gen/JSON/Unconstrained.hs +++ b/src/Hedgehog/Gen/JSON/Unconstrained.hs @@ -7,6 +7,7 @@ import Hedgehog import qualified Hedgehog.Gen as Gen import Hedgehog.Gen.JSON.Ranges +import Protolude genNull :: Gen A.Value genNull = pure A.Null @@ -36,12 +37,4 @@ (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 - ] +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 --- a/test/Hedgehog/Gen/JSON/Constrained/Internal/InternalSpec.hs +++ b/test/Hedgehog/Gen/JSON/Constrained/Internal/InternalSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Gen.JSON.Constrained.Internal.InternalSpec @@ -17,7 +15,7 @@ import Protolude import Test.Tasty import Test.Tasty.Hedgehog -import Text.Regex.Posix +import Text.Regex.PCRE prop_genBoundedInteger :: Property prop_genBoundedInteger = @@ -84,12 +82,13 @@ 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 +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 = 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 @@ -1,28 +1,26 @@ -{-# 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 +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.PCRE prop_generatedUnconstrainedJSON :: Property prop_generatedUnconstrainedJSON = @@ -56,8 +54,7 @@ let schema = (set schemaMinimum (NumberConstraintMinimum <$> vmin) . set schemaMaximum (NumberConstraintMaximum <$> vmax) . - set schemaExclusiveMinimum (NumberConstraintExclusiveMinimum <$> vminEx) . - set schemaExclusiveMaximum (NumberConstraintExclusiveMaximum <$> vmaxEx)) + set schemaExclusiveMinimum (NumberConstraintExclusiveMinimum <$> vminEx) . set schemaExclusiveMaximum (NumberConstraintExclusiveMaximum <$> vmaxEx)) (singleTypeSchema NumberType) (Aeson.Number v) <- forAll $ genConstrainedJSONValue sensibleRanges schema assert $ maybe True (v >=) vmin @@ -77,8 +74,7 @@ (set schemaMinimum (NumberConstraintMinimum <$> vmin) . set schemaMaximum (NumberConstraintMaximum <$> vmax) . set schemaExclusiveMinimum (NumberConstraintExclusiveMinimum <$> vminEx) . - set schemaExclusiveMaximum (NumberConstraintExclusiveMaximum <$> vmaxEx) . - set schemaMultipleOf (NumberConstraintMultipleOf <$> multipleOf)) + set schemaExclusiveMaximum (NumberConstraintExclusiveMaximum <$> vmaxEx) . set schemaMultipleOf (NumberConstraintMultipleOf <$> multipleOf)) (singleTypeSchema IntegerType) (Aeson.Number v) <- forAll $ genConstrainedJSONValue sensibleRanges schema assert $ maybe True (v >=) vmin @@ -94,26 +90,25 @@ 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. + format <- forAll $ Gen.maybe $ Gen.element ["uuid", "date-time", "RFC 3339 date-time"] let schema = (set schemaPattern (StringConstraintPattern <$> regexp) . set schemaMinLength (StringConstraintMinLength <$> minLength) . - set schemaMaxLength (StringConstraintMaxLength <$> maxLength)) + set schemaMaxLength (StringConstraintMaxLength <$> maxLength) . set schemaFormat (StringConstraintFormat <$> format)) (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 + case regexp of + Just p -> regexMatches p v + Nothing -> + case format of + (Just f) -> hasFormat (StringConstraintFormat f) v + Nothing -> assert $ 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)) + 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)) @@ -131,8 +126,7 @@ let schema = (set schemaMinItems (ArrayConstraintMinItems <$> minItems) . set schemaMaxItems (ArrayConstraintMaxItems <$> maxItems) . - set schemaUniqueItems (ArrayConstraintUniqueItems <$> uniqueItems) . - set schemaItems (Just $ ArrayConstraintItems itemSchema)) + set schemaUniqueItems (ArrayConstraintUniqueItems <$> uniqueItems) . set schemaItems (Just $ ArrayConstraintItems itemSchema)) (singleTypeSchema ArrayType) (Aeson.Array v) <- forAll $ genConstrainedJSONValue sensibleRanges schema assert $ maybe True (length v >=) minItems @@ -149,15 +143,13 @@ 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\"]}" 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)]))) + ((Just . ObjectConstraintProperties) (H.fromList [("user_id", singleTypeSchema IntegerType), ("user_domain", singleTypeSchema StringType)]))) (singleTypeSchema ObjectType) genSchema :: Gen Schema @@ -170,6 +162,22 @@ isUnique :: (Hashable a, Eq a, Foldable t) => t a -> Bool isUnique xs = (toList . HS.fromList . toList) xs == toList xs + +regexMatches :: (MonadTest m, HasCallStack) => Text -> Text -> m () +regexMatches regex t = do + footnoteShow (t <> " does not match the regexp " <> regex) + assert $ (toS t :: P.String) =~ (toS regex :: P.String) + +hasFormat :: (MonadTest m) => StringConstraintFormat -> Text -> m () +hasFormat (StringConstraintFormat "uuid") t = + footnoteShow (t <> " does hot have the format of uuid") >> regexMatches "[a-f0-9]{8}-?[a-f0-9]{4}-?4[a-f0-9]{3}-?[89ab][a-f0-9]{3}-?[a-f0-9]{12}" t +hasFormat (StringConstraintFormat "date-time") t = + footnoteShow (t <> " does hot have the format of date-time") >> + regexMatches + "([0-9]+)-(0[1-9]|1[012])-(0[1-9]|[12][0-9]|3[01])[Tt]([01][0-9]|2[0-3]):([0-5][0-9]):([0-5][0-9]|60)(\\.[0-9]+)?(([Zz])|([\\+|\\-]([01][0-9]|2[0-3]):[0-5][0-9]))" + t +hasFormat (StringConstraintFormat "RFC 3339 date-time") t = hasFormat (StringConstraintFormat "date-time") t +hasFormat _ _ = footnote "Format unsupported" >> failure tests :: TestTree tests =