git.iko.soy/typeable/swagger2
on master help sign in
Merge pull request #162 from benweitzman/master

add a quickcheck generator for aeson Values that match a swagger schema

commit151331d449c2895f342eda4550dff69659cb52a8 authorOleg Grenrus <oleg.grenrus@iki.fi> dateTue 30 Oct 2018, 16:28 (8 years ago) parent24c29c3faa86b3
3 files changed+278−1
compare with master
unifiedsplit
src/Data/Swagger/Schema/Generator.hs+106 swagger2.cabal+4−1 test/Data/Swagger/Schema/GeneratorSpec.hs+168
src/Data/Swagger/Schema/Generator.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE OverloadedLists #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Data.Swagger.Schema.Generator where
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Control.Lens.Operators
11+import Control.Monad (filterM)
12+import Data.Aeson
13+import Data.Aeson.Types
14+import qualified Data.HashMap.Strict.InsOrd as M
15+import Data.Maybe
16+import Data.Maybe
17+import Data.Proxy
18+import Data.Scientific
19+import qualified Data.Set as S
20+import Data.Swagger
21+import Data.Swagger.Declare
22+import qualified Data.Text as T
23+import qualified Data.Vector as V
24+import Test.QuickCheck (arbitrary)
25+import Test.QuickCheck.Gen
26+import Test.QuickCheck.Property
27+
28+schemaGen :: Definitions Schema -> Schema -> Gen Value
29+schemaGen _ schema
30+ | Just cases <- schema ^. paramSchema . enum_ = elements cases
31+schemaGen defns schema =
32+ case schema ^. type_ of
33+ SwaggerBoolean -> Bool <$> elements [True, False]
34+ SwaggerNull -> pure Null
35+ SwaggerNumber
36+ | Just min <- schema ^. minimum_
37+ , Just max <- schema ^. maximum_ ->
38+ Number . fromFloatDigits <$>
39+ choose (toRealFloat min, toRealFloat max :: Double)
40+ | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
41+ SwaggerInteger
42+ | Just min <- schema ^. minimum_
43+ , Just max <- schema ^. maximum_ ->
44+ Number . fromInteger <$>
45+ choose (truncate min, truncate max)
46+ | otherwise -> Number . fromInteger <$> arbitrary
47+ SwaggerArray
48+ | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
49+ | Just items <- schema ^. items ->
50+ case items of
51+ SwaggerItemsObject ref -> do
52+ size <- getSize
53+ let itemSchema = dereference defns ref
54+ minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
55+ maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems
56+ arrayLength <- choose (minLength', max minLength' maxLength')
57+ generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
58+ return . Array $ V.fromList generatedArray
59+ SwaggerItemsArray refs ->
60+ let itemGens = schemaGen defns . dereference defns <$> refs
61+ in fmap (Array . V.fromList) $ sequence itemGens
62+ SwaggerString -> do
63+ size <- getSize
64+ let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
65+ let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
66+ length <- choose (minLength', max minLength' maxLength')
67+ str <- vectorOf length arbitrary
68+ return . String $ T.pack str
69+ SwaggerObject -> do
70+ size <- getSize
71+ let props = dereference defns <$> schema ^. properties
72+ reqKeys = S.fromList $ schema ^. required
73+ allKeys = S.fromList . M.keys $ schema ^. properties
74+ optionalKeys = allKeys S.\\ reqKeys
75+ minProps' = fromMaybe (length reqKeys) $
76+ fromInteger <$> schema ^. minProperties
77+ maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties
78+ shuffledOptional <- shuffle $ S.toList optionalKeys
79+ numProps <- choose (minProps', max minProps' maxProps')
80+ let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional
81+ let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
82+ let gens = schemaGen defns <$> presentProps
83+ additionalGens <- case schema ^. additionalProperties of
84+ Just (AdditionalPropertiesSchema addlSchema) -> do
85+ additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary
86+ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
87+ _ -> return []
88+ x <- sequence $ gens <> additionalGens
89+ return . Object $ M.toHashMap x
90+ where
91+ dereference :: Definitions a -> Referenced a -> a
92+ dereference _ (Inline a) = a
93+ dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
94+
95+genValue :: (ToSchema a) => Proxy a -> Gen Value
96+genValue p =
97+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
98+ in schemaGen defs schema
99+
100+validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
101+validateFromJSON p = forAll (genValue p) $
102+ \val -> case parseEither parseJSON val of
103+ Right (_ :: a) -> succeeded
104+ Left err -> failed
105+ { reason = err
106+ }
swagger2.cabal+4−1
@@ -46,6 +46,7 @@ library
4646 Data.Swagger.Operation
4747 Data.Swagger.ParamSchema
4848 Data.Swagger.Schema
49+ Data.Swagger.Schema.Generator
4950 Data.Swagger.Schema.Validation
5051 Data.Swagger.SchemaOptions
5152
@@ -86,6 +87,7 @@ library
8687 , unordered-containers >=0.2.9.0 && <0.3
8788 , uuid-types >=1.0.3 && <1.1
8889 , vector >=0.12.0.1 && <0.13
90+ , QuickCheck >=2.10.1 && <2.12
8991
9092 default-language: Haskell2010
9193
@@ -96,7 +98,7 @@ test-suite spec
9698
9799 -- From library parat
98100 -- We need aeson's toEncoding for doctests too
99− build-depends:
101+ build-depends:
100102 base
101103 , swagger2
102104 , aeson
@@ -132,6 +134,7 @@ test-suite spec
132134 Data.Swagger.ParamSchemaSpec
133135 Data.Swagger.SchemaSpec
134136 Data.Swagger.Schema.ValidationSpec
137+ Data.Swagger.Schema.GeneratorSpec
135138
136139 Data.Aeson.QQ.Simple
137140 default-language: Haskell2010
test/Data/Swagger/Schema/GeneratorSpec.hsnew file+168
@@ -0,0 +1,168 @@
1+{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE PackageImports #-}
4+module Data.Swagger.Schema.GeneratorSpec where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import Data.Swagger
10+import Data.Swagger.Schema.Generator
11+
12+import Control.Lens.Operators
13+import Data.Aeson
14+import Data.Hashable (Hashable)
15+import Data.HashMap.Strict (HashMap)
16+import qualified Data.HashMap.Strict as HashMap
17+import "unordered-containers" Data.HashSet (HashSet)
18+import qualified "unordered-containers" Data.HashSet as HashSet
19+import Data.Int
20+import Data.IntMap (IntMap)
21+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
22+import Data.Map (Map, fromList)
23+import Data.Monoid (mempty)
24+import Data.Proxy
25+import Data.Proxy
26+import Data.Set (Set)
27+import qualified Data.Text as T
28+import qualified Data.Text.Lazy as TL
29+import Data.Time
30+import Data.Version (Version)
31+import Data.Word
32+import GHC.Generics
33+
34+import Test.Hspec
35+import Test.Hspec.QuickCheck
36+import Test.QuickCheck
37+
38+shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
39+shouldValidate = validateFromJSON
40+
41+
42+shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
43+shouldNotValidate = expectFailure . shouldValidate
44+
45+
46+spec :: Spec
47+spec = do
48+ describe "FromJSON validation" $ do
49+ prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
50+ prop "Char" $ shouldValidate (Proxy :: Proxy Char)
51+ prop "Double" $ shouldValidate (Proxy :: Proxy Double)
52+ prop "Float" $ shouldValidate (Proxy :: Proxy Float)
53+ prop "Int" $ shouldValidate (Proxy :: Proxy Int)
54+ prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
55+ prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
56+ prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
57+ prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
58+ prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
59+ prop "Word" $ shouldValidate (Proxy :: Proxy Word)
60+ prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
61+ prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
62+ prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
63+ prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
64+ prop "String" $ shouldValidate (Proxy :: Proxy String)
65+ prop "()" $ shouldValidate (Proxy :: Proxy ())
66+-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
67+-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
68+ prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
69+ prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
70+ prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
71+ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
72+ prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
73+ prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
74+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
75+ prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
76+ prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
77+ prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
78+ prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
79+ prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
80+ prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
81+ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
82+ prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
83+ prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
84+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)
85+ prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
86+ prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
87+ prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
88+ describe "Invalid FromJSON validation" $ do
89+ prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)
90+ prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
91+ prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
92+ prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)
93+
94+-- =============================
95+-- Data types and bunk instances
96+-- =============================
97+
98+data WrongType = WrongType Bool
99+
100+instance FromJSON WrongType where
101+ parseJSON = withBool "WrongType" $ return . WrongType
102+
103+instance ToSchema WrongType where
104+ declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105+ mempty
106+ & type_ .~ SwaggerObject
107+
108+
109+data MissingRequired = MissingRequired
110+ { propA :: String
111+ , propB :: Bool
112+ }
113+
114+instance FromJSON MissingRequired where
115+ parseJSON = withObject "MissingRequired" $ \o ->
116+ MissingRequired
117+ <$> o .: "propA"
118+ <*> o .: "propB"
119+
120+instance ToSchema MissingRequired where
121+ declareNamedSchema _ = do
122+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)
123+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124+ return . NamedSchema (Just "MissingRequired") $
125+ mempty
126+ & type_ .~ SwaggerObject
127+ & properties .~ [("propA", stringSchema)
128+ ,("propB", boolSchema)
129+ ]
130+ & required .~ ["propA"]
131+
132+data MissingProperty = MissingProperty
133+ { propC :: String
134+ , propD :: Bool
135+ }
136+
137+instance FromJSON MissingProperty where
138+ parseJSON = withObject "MissingProperty" $ \o ->
139+ MissingProperty
140+ <$> o .: "propC"
141+ <*> o .: "propD"
142+
143+instance ToSchema MissingProperty where
144+ declareNamedSchema _ = do
145+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146+ return . NamedSchema (Just "MissingProperty") $
147+ mempty
148+ & type_ .~ SwaggerObject
149+ & properties .~ [("propC", stringSchema)]
150+ & required .~ ["propC"]
151+
152+data WrongPropType = WrongPropType
153+ { propE :: String
154+ }
155+
156+instance FromJSON WrongPropType where
157+ parseJSON = withObject "WrongPropType" $ \o ->
158+ WrongPropType
159+ <$> o .: "propE"
160+
161+instance ToSchema WrongPropType where
162+ declareNamedSchema _ = do
163+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164+ return . NamedSchema (Just "WrongPropType") $
165+ mempty
166+ & type_ .~ SwaggerObject
167+ & properties .~ [("propE", boolSchema)]
168+ & required .~ ["propE"]