@@ -0,0 +1,79 @@
2+{-# LANGUAGE ScopedTypeVariables #-}
4+module Data.Swagger.Schema.Generator where
6+import Control.Lens.Operators
9+import Data.Aeson.Types
10+import qualified Data.HashMap.Strict.InsOrd as M
13+import Data.Scientific
15+import Data.Swagger.Declare
16+import qualified Data.Text as T
17+import qualified Data.Vector as V
18+import Test.QuickCheck (arbitrary)
19+import Test.QuickCheck.Gen
20+import Test.QuickCheck.Property
22+schemaGen :: Definitions Schema -> Schema -> Gen Value
24+ | Just cases <- schema ^. paramSchema . enum_ = elements cases
25+schemaGen defns schema =
26+ case schema ^. type_ of
27+ SwaggerBoolean -> Bool <$> elements [True, False]
28+ SwaggerNull -> pure Null
30+ | Just min <- schema ^. minimum_
31+ , Just max <- schema ^. maximum_ ->
32+ Number . fromFloatDigits <$>
33+ choose (toRealFloat min, toRealFloat max :: Double)
34+ | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
36+ | Just min <- schema ^. minimum_
37+ , Just max <- schema ^. maximum_ ->
38+ Number . fromInteger <$>
39+ choose (truncate min, truncate max)
40+ | otherwise -> Number . fromInteger <$> arbitrary
42+ | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
43+ | Just items <- schema ^. items ->
45+ SwaggerItemsObject ref ->
46+ let itemSchema = dereference defns ref
47+ in fmap (Array . V.fromList) . listOf $ schemaGen defns itemSchema
48+ SwaggerItemsArray refs ->
49+ let itemGens = schemaGen defns . dereference defns <$> refs
50+ in fmap (Array . V.fromList) $ sequence itemGens
51+ SwaggerString -> String . T.pack <$> arbitrary
53+ let props = dereference defns <$> schema ^. properties
54+ reqKeys = schema ^. required
55+ allKeys = M.keys $ schema ^. properties
56+ presentKeys <- filterM (\key -> if key `elem` reqKeys
58+ else arbitrary) allKeys
59+ let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
60+ let gens = schemaGen defns <$> presentProps
62+ return . Object $ M.toHashMap x
64+ dereference :: Definitions a -> Referenced a -> a
65+ dereference _ (Inline a) = a
66+ dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
68+genValue :: (ToSchema a) => Proxy a -> Gen Value
70+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
71+ in schemaGen defs schema
73+validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
74+validateFromJSON p = forAll (genValue p) $
75+ \val -> case parseEither parseJSON val of
76+ Right (_ :: a) -> succeeded