graphql-engine/server/src-test/Hasura/Generator.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Hasura.Generator () where

import           Hasura.Prelude

import qualified Data.HashMap.Strict           as Map
import qualified Data.Text                     as T
import qualified Language.GraphQL.Draft.Syntax as G

import           Data.Containers.ListUtils     (nubOrd)
import           Data.Ratio                    ((%))
import           Test.QuickCheck

import           Hasura.RQL.Types.RemoteSchema
import           Hasura.RQL.Types.SchemaCache  (IntrospectionResult (..))
import           Hasura.Server.Utils
import           Hasura.Session


-- Quickcheck helpers

distinct :: (Arbitrary a, Ord a) => Gen [a]
distinct = nubOrd <$> arbitrary

distinct1 :: (Arbitrary a, Ord a) => Gen [a]
distinct1 = nubOrd <$> listOf1 arbitrary

arbitraryExcluding :: (Arbitrary a, Eq a) => [a] -> Gen a
arbitraryExcluding exclusions = arbitrary `suchThat` (`notElem` exclusions)

distinctExcluding :: (Arbitrary a, Ord a) => [a] -> Gen [a]
distinctExcluding = fmap nubOrd . listOf . arbitraryExcluding

distinctExcluding1 :: (Arbitrary a, Ord a) => [a] -> Gen [a]
distinctExcluding1 = fmap nubOrd . listOf1 . arbitraryExcluding

sublistOf1 :: [a] -> Gen [a]
sublistOf1 xs = sublistOf xs `suchThat` (not . null)


-- Third party instances

instance Arbitrary Text where
  arbitrary = T.pack <$> listOf arbitraryUnicodeChar

instance (Arbitrary k, Eq k, Hashable k, Arbitrary v) => Arbitrary (HashMap k v) where
  arbitrary = Map.fromList <$> arbitrary


-- GraphQL syntax instances

instance Arbitrary G.Name where
  arbitrary = G.unsafeMkName . T.pack <$> listOf1 (elements ['a'..'z'])

instance Arbitrary G.Description where
 arbitrary = G.Description <$> arbitrary

instance Arbitrary G.EnumValue where
  arbitrary = G.EnumValue <$> arbitrary

instance Arbitrary G.EnumValueDefinition where
  arbitrary = G.EnumValueDefinition
    <$> arbitrary
    <*> arbitrary
    <*> pure []

instance Arbitrary G.Nullability where
  arbitrary = G.Nullability <$> arbitrary

instance Arbitrary (G.Value Void) where
  arbitrary = oneof
    [ pure G.VNull
    , G.VInt <$> arbitrary
    , G.VFloat <$> arbitraryScientific
    , G.VString <$> arbitrary
    , G.VBoolean <$> arbitrary
    , G.VEnum <$> arbitrary
    -- reduce the internal size factor at every level, so that this
    -- recursion is guaranteed to terminate
    , G.VList   <$> scale (`div` 2) arbitrary
    , G.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)



-- Hasura instances

instance Arbitrary SessionVariable where
  arbitrary = do
    name <- arbitrary
    pure $  mkSessionVariable $ 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 $ concat
          [ G.TypeDefinitionScalar <$> scalarTypeDefinitions
          , G.TypeDefinitionObject <$> objectTypeDefinitions
          , G.TypeDefinitionInterface <$> interfaceTypeDefinitions
          , G.TypeDefinitionUnion <$> unionTypeDefinitions
          , G.TypeDefinitionEnum <$> enumTypeDefinitions
          , G.TypeDefinitionInputObject <$> inputObjectTypeDefinitions
          ]
    irQueryRoot <- elements objectTypeNames
    let maybeObjectTypeName = elements $ Nothing : (Just <$> objectTypeNames)
    irMutationRoot <- maybeObjectTypeName
    irSubscriptionRoot <- maybeObjectTypeName
    pure $ IntrospectionResult {..}


-- Generator helpers

genGType :: [G.Name] -> Gen G.GType
genGType typeNames = frequency
  -- bias towards avoiding deeply nested lists
  [ (7, G.TypeNamed <$> arbitrary <*> elements typeNames)
  , (3, G.TypeList  <$> arbitrary <*> genGType typeNames)
  ]

genInputValueDefinition :: [G.Name] -> Gen G.InputValueDefinition
genInputValueDefinition inputTypeNames = G.InputValueDefinition
  <$> arbitrary
  <*> arbitrary
  <*> genGType inputTypeNames
  <*> arbitrary
  <*> pure []

genScalarTypeDefinition :: G.Name -> Gen G.ScalarTypeDefinition
genScalarTypeDefinition name = G.ScalarTypeDefinition
  <$> arbitrary
  <*> pure name
  <*> pure []

genEnumTypeDefinition :: G.Name -> Gen G.EnumTypeDefinition
genEnumTypeDefinition name = G.EnumTypeDefinition
  <$> arbitrary
  <*> pure name
  <*> pure []
  <*> listOf1 arbitrary

genUnionTypeDefinition :: [G.Name] -> G.Name -> Gen G.UnionTypeDefinition
genUnionTypeDefinition objectTypeNames name = G.UnionTypeDefinition
  <$> arbitrary
  <*> pure name
  <*> pure []
  <*> sublistOf1 objectTypeNames

genFieldDefinition
  :: Gen [inputType]
  -> [G.Name]
  -> G.Name
  -> Gen (G.FieldDefinition inputType)
genFieldDefinition inputTypes outputTypeNames name = G.FieldDefinition
  <$> arbitrary
  <*> pure name
  <*> inputTypes
  <*> genGType outputTypeNames
  <*> pure []

genObjectTypeDefinition
  :: Gen [inputType]
  -> [G.Name]
  -> [G.Name]
  -> G.Name
  -> Gen (G.ObjectTypeDefinition inputType)
genObjectTypeDefinition inputTypes outputTypeNames interfaceTypeNames name = G.ObjectTypeDefinition
  <$> arbitrary
  <*> pure name
  <*> sublistOf interfaceTypeNames
  <*> pure []
  <*> fields
  where
    fields = distinct1 >>= traverse (genFieldDefinition inputTypes outputTypeNames)

genInterfaceTypeDefinition
  :: Arbitrary possibleType
  => Gen [inputType]
  -> [G.Name]
  -> G.Name
  -> Gen (G.InterfaceTypeDefinition [possibleType] inputType)
genInterfaceTypeDefinition inputTypes outputTypeNames name = G.InterfaceTypeDefinition
  <$> arbitrary
  <*> pure name
  <*> pure []
  <*> fields
  <*> listOf1 arbitrary
  where
    fields = distinct1 >>= traverse (genFieldDefinition inputTypes outputTypeNames)

genInputObjectTypeDefinition
  :: Gen [inputType]
  -> G.Name
  -> Gen (G.InputObjectTypeDefinition inputType)
genInputObjectTypeDefinition values name = G.InputObjectTypeDefinition
  <$> arbitrary
  <*> pure name
  <*> pure []
  <*> values

genRemoteSchemaInputValueDefinition :: [G.Name] -> Gen RemoteSchemaInputValueDefinition
genRemoteSchemaInputValueDefinition inputTypeNames = RemoteSchemaInputValueDefinition
  <$> genInputValueDefinition inputTypeNames
  <*> pure Nothing