{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedLists     #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.OpenApi.Schema.Generator where

import           Prelude                                 ()
import           Prelude.Compat

import           Control.Lens.Operators
import           Control.Monad                           (filterM)
import           Data.Aeson
import           Data.Aeson.Types
import qualified Data.HashMap.Strict.InsOrd              as M
import           Data.Maybe
import           Data.Proxy
import           Data.Scientific
import qualified Data.Set                                as S
import           Data.OpenApi
import           Data.OpenApi.Declare
import           Data.OpenApi.Internal.Schema.Validation (inferSchemaTypes)
import qualified Data.Text                               as T
import qualified Data.Vector                             as V
import           Test.QuickCheck                         (arbitrary)
import           Test.QuickCheck.Gen
import           Test.QuickCheck.Property

import Data.OpenApi.Aeson.Compat (fromInsOrdHashMap)

-- | Note: 'schemaGen' may 'error', if schema type is not specified,
-- and cannot be inferred.
schemaGen :: Definitions Schema -> Schema -> Gen Value
schemaGen :: Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
_ Schema
schema
    | Just [Value]
cases <- Schema
schema  forall s a. s -> Getting a s a -> a
^. forall s a. HasEnum s a => Lens' s a
enum_  = forall a. [a] -> Gen a
elements [Value]
cases
schemaGen Definitions Schema
defns Schema
schema
    | Just [Referenced Schema]
variants <- Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasOneOf s a => Lens' s a
oneOf = Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. [a] -> Gen a
elements (forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Referenced Schema]
variants)
schemaGen Definitions Schema
defns Schema
schema =
    case Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasType s a => Lens' s a
type_ of
      Maybe OpenApiType
Nothing ->
        case Schema -> [OpenApiType]
inferSchemaTypes Schema
schema of
          [ Item [OpenApiType]
inferredType ] -> Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns (Schema
schema forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Item [OpenApiType]
inferredType)
          -- Gen is not MonadFail
          [OpenApiType]
_ -> forall a. HasCallStack => String -> a
error String
"unable to infer schema type"
      Just OpenApiType
OpenApiBoolean -> Bool -> Value
Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Gen a
elements [Bool
True, Bool
False]
      Just OpenApiType
OpenApiNull    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
      Just OpenApiType
OpenApiNumber
        | Just Scientific
min <- Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMinimum s a => Lens' s a
minimum_
        , Just Scientific
max <- Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMaximum s a => Lens' s a
maximum_ ->
            Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> Scientific
fromFloatDigits forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   forall a. Random a => (a, a) -> Gen a
choose (forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
min, forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
max :: Double)
        | Bool
otherwise -> Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. RealFloat a => a -> Scientific
fromFloatDigits forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Arbitrary a => Gen a
arbitrary :: Gen Double)
      Just OpenApiType
OpenApiInteger
        | Just Scientific
min <- Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMinimum s a => Lens' s a
minimum_
        , Just Scientific
max <- Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMaximum s a => Lens' s a
maximum_ ->
            Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   forall a. Random a => (a, a) -> Gen a
choose (forall a b. (RealFrac a, Integral b) => a -> b
truncate Scientific
min, forall a b. (RealFrac a, Integral b) => a -> b
truncate Scientific
max)
        | Bool
otherwise -> Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
      Just OpenApiType
OpenApiArray
        | Just Integer
0 <- Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMaxLength s a => Lens' s a
maxLength -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Array -> Value
Array forall a. Vector a
V.empty
        | Just OpenApiItems
items <- Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasItems s a => Lens' s a
items ->
            case OpenApiItems
items of
              OpenApiItemsObject Referenced Schema
ref -> do
                  Int
size <- Gen Int
getSize
                  let itemSchema :: Schema
itemSchema = forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns Referenced Schema
ref
                      minLength' :: Int
minLength' = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMinItems s a => Lens' s a
minItems
                      maxLength' :: Int
maxLength' = forall a. a -> Maybe a -> a
fromMaybe Int
size forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMaxItems s a => Lens' s a
maxItems
                  Int
arrayLength <- forall a. Random a => (a, a) -> Gen a
choose (Int
minLength', forall a. Ord a => a -> a -> a
max Int
minLength' Int
maxLength')
                  [Value]
generatedArray <- forall a. Int -> Gen a -> Gen [a]
vectorOf Int
arrayLength forall a b. (a -> b) -> a -> b
$ Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns Schema
itemSchema
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Array forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
V.fromList [Value]
generatedArray
              OpenApiItemsArray [Referenced Schema]
refs ->
                  let itemGens :: [Gen Value]
itemGens = Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Referenced Schema]
refs
                  in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Array -> Value
Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
V.fromList) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Gen Value]
itemGens
      Just OpenApiType
OpenApiString -> do
        Int
size <- Gen Int
getSize
        let minLength' :: Int
minLength' = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMinLength s a => Lens' s a
minLength
        let maxLength' :: Int
maxLength' = forall a. a -> Maybe a -> a
fromMaybe Int
size forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMaxLength s a => Lens' s a
maxLength
        Int
length <- forall a. Random a => (a, a) -> Gen a
choose (Int
minLength', forall a. Ord a => a -> a -> a
max Int
minLength' Int
maxLength')
        String
str <- forall a. Int -> Gen a -> Gen [a]
vectorOf Int
length forall a. Arbitrary a => Gen a
arbitrary
        forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str
      Just OpenApiType
OpenApiObject -> do
          Int
size <- Gen Int
getSize
          let props :: Definitions Schema
props = forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasProperties s a => Lens' s a
properties
              reqKeys :: Set Text
reqKeys = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasRequired s a => Lens' s a
required
              allKeys :: Set Text
allKeys = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. InsOrdHashMap k v -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasProperties s a => Lens' s a
properties
              optionalKeys :: Set Text
optionalKeys = Set Text
allKeys forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Text
reqKeys
              minProps' :: Int
minProps' = forall a. a -> Maybe a -> a
fromMaybe (forall (t :: * -> *) a. Foldable t => t a -> Int
length Set Text
reqKeys) forall a b. (a -> b) -> a -> b
$
                            forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMinProperties s a => Lens' s a
minProperties
              maxProps' :: Int
maxProps' = forall a. a -> Maybe a -> a
fromMaybe Int
size forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasMaxProperties s a => Lens' s a
maxProperties
          [Text]
shuffledOptional <- forall a. [a] -> Gen [a]
shuffle forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set Text
optionalKeys
          Int
numProps <- forall a. Random a => (a, a) -> Gen a
choose (Int
minProps', forall a. Ord a => a -> a -> a
max Int
minProps' Int
maxProps')
          let presentKeys :: [Text]
presentKeys = forall a. Int -> [a] -> [a]
take Int
numProps forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set Text
reqKeys forall a. [a] -> [a] -> [a]
++ [Text]
shuffledOptional
          let presentProps :: Definitions Schema
presentProps = forall k v.
(k -> v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v
M.filterWithKey (\Text
k Schema
_ -> Text
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
presentKeys) Definitions Schema
props
          let gens :: InsOrdHashMap Text (Gen Value)
gens = Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Definitions Schema
presentProps
          InsOrdHashMap Text (Gen Value)
additionalGens <- case Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasAdditionalProperties s a => Lens' s a
additionalProperties of
            Just (AdditionalPropertiesSchema Referenced Schema
addlSchema) -> do
              [Text]
additionalKeys <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take (Int
numProps forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length Definitions Schema
presentProps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a]
repeat forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
              forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
additionalKeys (forall a. a -> [a]
repeat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns forall a b. (a -> b) -> a -> b
$ forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns Referenced Schema
addlSchema)
            Maybe AdditionalProperties
_                                      -> forall (m :: * -> *) a. Monad m => a -> m a
return []
          InsOrdHashMap Text Value
x <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ InsOrdHashMap Text (Gen Value)
gens forall a. Semigroup a => a -> a -> a
<> InsOrdHashMap Text (Gen Value)
additionalGens
          forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. InsOrdHashMap Text v -> KeyMap v
fromInsOrdHashMap InsOrdHashMap Text Value
x

dereference :: Definitions a -> Referenced a -> a
dereference :: forall a. Definitions a -> Referenced a -> a
dereference Definitions a
_ (Inline a
a)               = a
a
dereference Definitions a
defs (Ref (Reference Text
ref)) = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
M.lookup Text
ref Definitions a
defs

genValue :: (ToSchema a) => Proxy a -> Gen Value
genValue :: forall a. ToSchema a => Proxy a -> Gen Value
genValue Proxy a
p =
 let (Definitions Schema
defs, NamedSchema Maybe Text
_ Schema
schema) = forall d a. Declare d a -> d -> (d, a)
runDeclare (forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy a
p) forall k v. InsOrdHashMap k v
M.empty
 in Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defs Schema
schema

validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
validateFromJSON :: forall a. (ToSchema a, FromJSON a) => Proxy a -> Property
validateFromJSON Proxy a
p = forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall a. ToSchema a => Proxy a -> Gen Value
genValue Proxy a
p) forall a b. (a -> b) -> a -> b
$
                       \Value
val -> case forall a b. (a -> Parser b) -> a -> Either String b
parseEither forall a. FromJSON a => Value -> Parser a
parseJSON Value
val of
                                 Right (a
_ :: a) -> Result
succeeded
                                 Left String
err -> Result
failed
                                               { reason :: String
reason = String
err
                                               }