mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 13:02:11 +03:00
a8424c48a1
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3888 GitOrigin-RevId: 027c319a66671a44fc6e5506bdfc9d2c10a8569f
398 lines
13 KiB
Haskell
398 lines
13 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Hasura.QuickCheck.Instances () where
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
import Data.Aeson qualified as Aeson
|
|
import Data.Aeson.Types qualified as Aeson.Types
|
|
import Data.HashMap.Strict.Extended qualified as HashMap
|
|
import Data.HashMap.Strict.InsOrd qualified as InsOrd.HashMap
|
|
import Data.HashMap.Strict.Multi qualified as MMap
|
|
import Data.HashSet qualified as HashSet
|
|
import Data.Ratio ((%))
|
|
import Data.Set qualified as Set
|
|
import Data.Text qualified as T
|
|
import Data.Trie qualified as Trie
|
|
import Hasura.Base.Error (QErr (..), QErrExtra (..))
|
|
import Hasura.Base.Error qualified as Error
|
|
import Hasura.GraphQL.Namespace (NamespacedField (..), namespacedField)
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.Types (ColumnConfig (..), Comment (..), CustomRootField (..), SourceName (..), TableCustomRootFields (..), getAllCustomRootFields)
|
|
import Hasura.RQL.Types.Endpoint.Trie
|
|
import Hasura.RQL.Types.Metadata.Object
|
|
( MetadataObjId (..),
|
|
MetadataObject (..),
|
|
)
|
|
import Hasura.RQL.Types.RemoteSchema
|
|
( RemoteSchemaInputValueDefinition (..),
|
|
RemoteSchemaIntrospection (..),
|
|
RemoteSchemaName (..),
|
|
getTypeName,
|
|
)
|
|
import Hasura.RQL.Types.SchemaCache (IntrospectionResult (..))
|
|
import Hasura.Server.Utils qualified as Utils
|
|
import Hasura.Session (SessionVariable, mkSessionVariable)
|
|
import Language.GraphQL.Draft.Syntax qualified as GraphQL
|
|
import Network.HTTP.Types qualified as HTTP.Types
|
|
import Test.QuickCheck.Extended
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Orphan instances for third-party libraries types
|
|
|
|
instance Arbitrary Text where
|
|
arbitrary = T.pack <$> listOf arbitraryUnicodeChar
|
|
|
|
instance
|
|
(Arbitrary k, Eq k, Hashable k, Arbitrary v) =>
|
|
Arbitrary (HashMap k v)
|
|
where
|
|
arbitrary = HashMap.fromList <$> arbitrary
|
|
shrink = fmap HashMap.fromList . shrink . HashMap.toList
|
|
|
|
instance
|
|
(Arbitrary k, Eq k, Hashable k, Arbitrary v) =>
|
|
Arbitrary (InsOrdHashMap k v)
|
|
where
|
|
arbitrary = InsOrd.HashMap.fromList <$> arbitrary
|
|
shrink = fmap InsOrd.HashMap.fromList . shrink . InsOrd.HashMap.toList
|
|
|
|
instance Arbitrary Aeson.Value where
|
|
arbitrary =
|
|
elements $
|
|
-- This is not exhaustive, because it wasn't needed.
|
|
[ Aeson.Object mempty,
|
|
Aeson.Array mempty,
|
|
Aeson.String mempty,
|
|
Aeson.Number 0,
|
|
Aeson.Bool False,
|
|
Aeson.Null
|
|
]
|
|
|
|
instance Arbitrary Aeson.Types.JSONPathElement where
|
|
arbitrary = Aeson.Types.Index <$> arbitrary
|
|
|
|
instance Arbitrary HTTP.Types.Status where
|
|
arbitrary = HTTP.Types.Status <$> arbitrary <*> pure mempty
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Orphan instances for types defined by us, but which are not coupled to
|
|
-- GraphQL Engine.
|
|
|
|
instance (Eq k, Hashable k, Arbitrary k, Eq v, Arbitrary v) => Arbitrary (Trie.Trie k v) where
|
|
arbitrary = Trie.Trie <$> scale (`div` 2) arbitrary <*> arbitrary
|
|
shrink (Trie.Trie m v) =
|
|
[Trie.Trie m v' | v' <- shrink v]
|
|
++ [Trie.Trie m' v | m' <- shrink m]
|
|
|
|
instance (Eq k, Hashable k, Arbitrary k, Ord v, Arbitrary v) => Arbitrary (MMap.MultiMap k v) where
|
|
arbitrary = MMap.fromMap . fmap (Set.fromList . take 5) <$> arbitrary
|
|
shrink m = map MMap.fromMap $ shrink $ MMap.toMap m
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Orphan instances for Language.GraphQL.Draft.Syntax types
|
|
--
|
|
-- TODO: We control `graphql-parser-hs`; we should upstream these orphan
|
|
-- instances as either a separate package (e.g. `graphql-parser-hs-quickcheck`)
|
|
-- or via flag (disabled by default) which enables QuickCheck as a dependency
|
|
-- and supplies (non-orphan) instances that way.
|
|
|
|
instance Arbitrary GraphQL.Name where
|
|
arbitrary =
|
|
GraphQL.unsafeMkName . T.pack <$> listOf1 (elements ['a' .. 'z'])
|
|
|
|
instance Arbitrary GraphQL.Description where
|
|
arbitrary = GraphQL.Description <$> arbitrary
|
|
|
|
instance Arbitrary GraphQL.EnumValue where
|
|
arbitrary = GraphQL.EnumValue <$> arbitrary
|
|
|
|
instance Arbitrary GraphQL.EnumValueDefinition where
|
|
arbitrary =
|
|
GraphQL.EnumValueDefinition
|
|
<$> arbitrary
|
|
<*> arbitrary
|
|
<*> pure []
|
|
|
|
instance Arbitrary GraphQL.Nullability where
|
|
arbitrary = GraphQL.Nullability <$> arbitrary
|
|
|
|
instance Arbitrary (GraphQL.Value Void) where
|
|
arbitrary =
|
|
oneof
|
|
[ pure GraphQL.VNull,
|
|
GraphQL.VInt <$> arbitrary,
|
|
GraphQL.VFloat <$> arbitraryScientific,
|
|
GraphQL.VString <$> arbitrary,
|
|
GraphQL.VBoolean <$> arbitrary,
|
|
GraphQL.VEnum <$> arbitrary,
|
|
-- reduce the internal size factor at every level, so that this
|
|
-- recursion is guaranteed to terminate
|
|
GraphQL.VList <$> scale (`div` 2) arbitrary,
|
|
GraphQL.VObject <$> scale (`div` 2) arbitrary
|
|
]
|
|
where
|
|
arbitraryScientific = do
|
|
-- fromRational can create invalid repeating values that loop forever
|
|
-- we avoid this by creating known good ratios
|
|
num :: Integer <- arbitrary
|
|
dem :: Integer <- elements [1 .. 32]
|
|
pure $ fromRational $ num % (10 ^ dem)
|
|
|
|
-- Generators for Language.GraphQL.Draft.Syntax types
|
|
|
|
genGType :: [GraphQL.Name] -> Gen GraphQL.GType
|
|
genGType typeNames =
|
|
frequency
|
|
-- bias towards avoiding deeply nested lists
|
|
[ (7, GraphQL.TypeNamed <$> arbitrary <*> elements typeNames),
|
|
(3, GraphQL.TypeList <$> arbitrary <*> genGType typeNames)
|
|
]
|
|
|
|
genInputValueDefinition :: [GraphQL.Name] -> Gen GraphQL.InputValueDefinition
|
|
genInputValueDefinition inputTypeNames =
|
|
GraphQL.InputValueDefinition
|
|
<$> arbitrary
|
|
<*> arbitrary
|
|
<*> genGType inputTypeNames
|
|
<*> arbitrary
|
|
<*> pure []
|
|
|
|
genScalarTypeDefinition :: GraphQL.Name -> Gen GraphQL.ScalarTypeDefinition
|
|
genScalarTypeDefinition name =
|
|
GraphQL.ScalarTypeDefinition
|
|
<$> arbitrary
|
|
<*> pure name
|
|
<*> pure []
|
|
|
|
genEnumTypeDefinition :: GraphQL.Name -> Gen GraphQL.EnumTypeDefinition
|
|
genEnumTypeDefinition name =
|
|
GraphQL.EnumTypeDefinition
|
|
<$> arbitrary
|
|
<*> pure name
|
|
<*> pure []
|
|
<*> listOf1 arbitrary
|
|
|
|
genUnionTypeDefinition ::
|
|
[GraphQL.Name] -> GraphQL.Name -> Gen GraphQL.UnionTypeDefinition
|
|
genUnionTypeDefinition objectTypeNames name =
|
|
GraphQL.UnionTypeDefinition
|
|
<$> arbitrary
|
|
<*> pure name
|
|
<*> pure []
|
|
<*> sublistOf1 objectTypeNames
|
|
|
|
genFieldDefinition ::
|
|
Gen [inputType] ->
|
|
[GraphQL.Name] ->
|
|
GraphQL.Name ->
|
|
Gen (GraphQL.FieldDefinition inputType)
|
|
genFieldDefinition inputTypes outputTypeNames name =
|
|
GraphQL.FieldDefinition
|
|
<$> arbitrary
|
|
<*> pure name
|
|
<*> inputTypes
|
|
<*> genGType outputTypeNames
|
|
<*> pure []
|
|
|
|
genObjectTypeDefinition ::
|
|
Gen [inputType] ->
|
|
[GraphQL.Name] ->
|
|
[GraphQL.Name] ->
|
|
GraphQL.Name ->
|
|
Gen (GraphQL.ObjectTypeDefinition inputType)
|
|
genObjectTypeDefinition inputTypes outputTypeNames interfaceTypeNames name =
|
|
GraphQL.ObjectTypeDefinition
|
|
<$> arbitrary
|
|
<*> pure name
|
|
<*> sublistOf interfaceTypeNames
|
|
<*> pure []
|
|
<*> fields
|
|
where
|
|
fields = distinct1 >>= traverse (genFieldDefinition inputTypes outputTypeNames)
|
|
|
|
genInterfaceTypeDefinition ::
|
|
Arbitrary possibleType =>
|
|
Gen [inputType] ->
|
|
[GraphQL.Name] ->
|
|
GraphQL.Name ->
|
|
Gen (GraphQL.InterfaceTypeDefinition [possibleType] inputType)
|
|
genInterfaceTypeDefinition inputTypes outputTypeNames name =
|
|
GraphQL.InterfaceTypeDefinition
|
|
<$> arbitrary
|
|
<*> pure name
|
|
<*> pure []
|
|
<*> fields
|
|
<*> listOf1 arbitrary
|
|
where
|
|
fields = distinct1 >>= traverse (genFieldDefinition inputTypes outputTypeNames)
|
|
|
|
genInputObjectTypeDefinition ::
|
|
Gen [inputType] ->
|
|
GraphQL.Name ->
|
|
Gen (GraphQL.InputObjectTypeDefinition inputType)
|
|
genInputObjectTypeDefinition values name =
|
|
GraphQL.InputObjectTypeDefinition
|
|
<$> arbitrary
|
|
<*> pure name
|
|
<*> pure []
|
|
<*> values
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Instances for GraphQL Engine types
|
|
|
|
instance Arbitrary a => Arbitrary (PathComponent a) where
|
|
arbitrary =
|
|
oneof
|
|
[ PathLiteral <$> arbitrary,
|
|
pure PathParam
|
|
]
|
|
|
|
instance Arbitrary SessionVariable where
|
|
arbitrary = do
|
|
name <- arbitrary
|
|
pure $ mkSessionVariable $ Utils.sessionVariablePrefix <> name
|
|
|
|
instance Arbitrary IntrospectionResult where
|
|
arbitrary = do
|
|
-- first, generate distinct names for each kind of object
|
|
scalarTypeNames <- distinct
|
|
objectTypeNames <- distinctExcluding1 scalarTypeNames
|
|
interfaceTypeNames <- distinctExcluding $ scalarTypeNames ++ objectTypeNames
|
|
unionTypeNames <- distinctExcluding $ scalarTypeNames ++ objectTypeNames ++ interfaceTypeNames
|
|
enumTypeNames <- distinctExcluding $ scalarTypeNames ++ objectTypeNames ++ interfaceTypeNames ++ unionTypeNames
|
|
let outputTypeNames = scalarTypeNames ++ objectTypeNames ++ interfaceTypeNames ++ unionTypeNames ++ enumTypeNames
|
|
inputObjectTypeNames <- distinctExcluding outputTypeNames
|
|
let inputTypeNames = scalarTypeNames ++ enumTypeNames ++ inputObjectTypeNames
|
|
let inputValues = case inputTypeNames of
|
|
[] -> pure []
|
|
_ -> listOf $ genRemoteSchemaInputValueDefinition inputTypeNames
|
|
|
|
-- then, create a matching definition for each name
|
|
scalarTypeDefinitions <-
|
|
for scalarTypeNames genScalarTypeDefinition
|
|
objectTypeDefinitions <-
|
|
for objectTypeNames $
|
|
genObjectTypeDefinition inputValues outputTypeNames interfaceTypeNames
|
|
interfaceTypeDefinitions <-
|
|
for interfaceTypeNames $
|
|
genInterfaceTypeDefinition inputValues outputTypeNames
|
|
unionTypeDefinitions <-
|
|
for unionTypeNames $
|
|
genUnionTypeDefinition objectTypeNames
|
|
enumTypeDefinitions <-
|
|
for enumTypeNames genEnumTypeDefinition
|
|
inputObjectTypeDefinitions <-
|
|
for inputObjectTypeNames $
|
|
genInputObjectTypeDefinition inputValues
|
|
|
|
-- finally, create an IntrospectionResult from the aggregated definitions
|
|
let irDoc =
|
|
RemoteSchemaIntrospection $
|
|
HashMap.fromListOn getTypeName $
|
|
concat
|
|
[ GraphQL.TypeDefinitionScalar <$> scalarTypeDefinitions,
|
|
GraphQL.TypeDefinitionObject <$> objectTypeDefinitions,
|
|
GraphQL.TypeDefinitionInterface <$> interfaceTypeDefinitions,
|
|
GraphQL.TypeDefinitionUnion <$> unionTypeDefinitions,
|
|
GraphQL.TypeDefinitionEnum <$> enumTypeDefinitions,
|
|
GraphQL.TypeDefinitionInputObject <$> inputObjectTypeDefinitions
|
|
]
|
|
irQueryRoot <- elements objectTypeNames
|
|
let maybeObjectTypeName = elements $ Nothing : (Just <$> objectTypeNames)
|
|
irMutationRoot <- maybeObjectTypeName
|
|
irSubscriptionRoot <- maybeObjectTypeName
|
|
pure $ IntrospectionResult {..}
|
|
|
|
instance Arbitrary a => Arbitrary (NamespacedField a) where
|
|
arbitrary = oneof [NotNamespaced <$> arbitrary, Namespaced <$> arbitrary]
|
|
shrink = namespacedField (fmap NotNamespaced . shrink) (fmap Namespaced . shrink)
|
|
|
|
instance Arbitrary QErrExtra where
|
|
arbitrary =
|
|
oneof
|
|
[ ExtraExtensions <$> arbitrary,
|
|
ExtraInternal <$> arbitrary
|
|
]
|
|
|
|
instance Arbitrary MetadataObjId where
|
|
arbitrary =
|
|
oneof
|
|
-- This is not exhaustive, because it wasn't needed.
|
|
[ pure $ MOSource SNDefault,
|
|
MORemoteSchema . RemoteSchemaName <$> arbitrary
|
|
]
|
|
|
|
instance Arbitrary MetadataObject where
|
|
arbitrary = MetadataObject <$> arbitrary <*> arbitrary
|
|
|
|
instance Arbitrary QErr where
|
|
arbitrary = do
|
|
-- This is not exhaustive, because it wasn't needed.
|
|
--
|
|
-- I just picked a few random error codes.
|
|
let genCode =
|
|
elements
|
|
[ Error.AlreadyExists,
|
|
Error.Conflict,
|
|
Error.ConstraintError,
|
|
Error.ConstraintViolation,
|
|
Error.NotFound,
|
|
Error.Unexpected
|
|
]
|
|
QErr
|
|
<$> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
<*> genCode
|
|
<*> arbitrary
|
|
|
|
instance Arbitrary Comment where
|
|
arbitrary =
|
|
oneof
|
|
[ pure Automatic,
|
|
Explicit <$> arbitrary
|
|
]
|
|
|
|
shrink Automatic = []
|
|
shrink (Explicit t) = Explicit <$> shrink t
|
|
|
|
instance Arbitrary CustomRootField where
|
|
arbitrary = CustomRootField <$> arbitrary <*> arbitrary
|
|
|
|
instance Arbitrary TableCustomRootFields where
|
|
arbitrary =
|
|
( TableCustomRootFields
|
|
<$> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
)
|
|
`suchThat` allFieldNamesAreUnique
|
|
where
|
|
allFieldNamesAreUnique :: TableCustomRootFields -> Bool
|
|
allFieldNamesAreUnique tcrf =
|
|
let allNames = mapMaybe _crfName $ getAllCustomRootFields tcrf
|
|
uniqueNames = HashSet.fromList allNames
|
|
in length allNames == length uniqueNames
|
|
|
|
instance Arbitrary ColumnConfig where
|
|
arbitrary =
|
|
ColumnConfig
|
|
<$> arbitrary
|
|
<*> arbitrary
|
|
|
|
-- Generators for GraphQL Engine types
|
|
|
|
genRemoteSchemaInputValueDefinition ::
|
|
[GraphQL.Name] -> Gen RemoteSchemaInputValueDefinition
|
|
genRemoteSchemaInputValueDefinition inputTypeNames =
|
|
RemoteSchemaInputValueDefinition
|
|
<$> genInputValueDefinition inputTypeNames
|
|
<*> pure Nothing
|