graphql-engine/server/src-test/Hasura/GraphQL/RemoteServerSpec.hs

{-# LANGUAGE TupleSections #-}
module Hasura.GraphQL.RemoteServerSpec (spec) where

import           Hasura.Prelude

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

import           Data.Containers.ListUtils     (nubOrd)
import           Data.Either                   (isRight)
import           Test.Hspec
import           Test.Hspec.QuickCheck
import           Test.QuickCheck

import           Hasura.Generator              ()
import           Hasura.GraphQL.RemoteServer
import           Hasura.RQL.Types.RemoteSchema
import           Hasura.RQL.Types.SchemaCache


spec :: Spec
spec = do
  describe "IntrospectionResult" $ do
    describe "getCustomizer" $ do
      prop "inverse" $
        forAllShrinkShow gen shrink_ show_ $ \(introspectionResult, typesAndFields, customization) ->
          let customizer = getCustomizer introspectionResult (Just customization)
              customizeTypeName = remoteSchemaCustomizeTypeName customizer
              customizeFieldName = remoteSchemaCustomizeFieldName customizer
              decustomizeTypeName = remoteSchemaDecustomizeTypeName customizer
              decustomizeFieldName = remoteSchemaDecustomizeFieldName customizer
              typeTests = conjoin $ Map.keys typesAndFields <&> \typeName ->
                decustomizeTypeName (customizeTypeName typeName) === typeName
              fieldTests = conjoin $ Map.toList typesAndFields <&> \(typeName, fieldNames) ->
                conjoin $ fieldNames <&> \fieldName ->
                  decustomizeFieldName (customizeTypeName typeName) (customizeFieldName typeName fieldName) === fieldName
          in
            isRight (validateSchemaCustomizationsDistinct customizer $ irDoc introspectionResult) ==>
              typeTests .&&. fieldTests

getTypesAndFields :: IntrospectionResult -> HashMap G.Name [G.Name]
getTypesAndFields IntrospectionResult {irDoc = RemoteSchemaIntrospection typeDefinitions} =
  Map.fromList $ map getTypeAndFields typeDefinitions
  where
    getTypeAndFields = \case
      G.TypeDefinitionScalar G.ScalarTypeDefinition {..} -> (_stdName, [])
      G.TypeDefinitionObject G.ObjectTypeDefinition {..} -> (_otdName, G._fldName <$> _otdFieldsDefinition)
      G.TypeDefinitionInterface G.InterfaceTypeDefinition {..} -> (_itdName, G._fldName <$> _itdFieldsDefinition)
      G.TypeDefinitionUnion G.UnionTypeDefinition {..} -> (_utdName, [])
      G.TypeDefinitionEnum G.EnumTypeDefinition {..} -> (_etdName, [])
      G.TypeDefinitionInputObject G.InputObjectTypeDefinition {..} -> (_iotdName, [])

genCustomization :: HashMap G.Name [G.Name] -> Gen RemoteSchemaCustomization
genCustomization typesAndFields = RemoteSchemaCustomization <$> arbitrary <*> fmap Just genTypeNames <*> fmap Just genFieldNames
  where
    genTypeNames = RemoteTypeCustomization <$> arbitrary <*> arbitrary <*> genMap (Map.keys typesAndFields)
    genFieldNames = do
      typesAndFields' <- sublistOf $ Map.toList typesAndFields
      for typesAndFields' $ \(typeName, fieldNames) ->
        RemoteFieldCustomization typeName <$> arbitrary <*> arbitrary <*> genMap fieldNames
    genMap names = do
      keys <- sublistOf names
      values <- nubOrd . filter (`notElem` names) <$> infiniteList
      pure $ Map.fromList $ zip keys values

gen :: Gen (IntrospectionResult, HashMap G.Name [G.Name], RemoteSchemaCustomization)
gen = do
  introspectionResult <- arbitrary
  let typesAndFields = getTypesAndFields introspectionResult
  customization <- genCustomization typesAndFields
  pure (introspectionResult, typesAndFields, customization)

shrink_ :: (IntrospectionResult, HashMap G.Name [G.Name], RemoteSchemaCustomization) -> [(IntrospectionResult, HashMap G.Name [G.Name], RemoteSchemaCustomization)]
shrink_ (introspectionResult, typesAndFields, customization@RemoteSchemaCustomization {..}) =
  (shrinkCustomization <&> (introspectionResult, typesAndFields,)) ++
  (shrinkTypesAndFields <&> (introspectionResult,,customization))
  where
    shrinkCustomization = shrinkNamespace ++ shrinkTypeNames ++ shrinkFieldNames

    shrinkMaybe _ Nothing  = []
    shrinkMaybe f (Just x) = Nothing : (Just <$> f x)

    shrinkMaybe' = shrinkMaybe shrinkNothing

    shrinkHashMap f = shrinkMapBy Map.fromList Map.toList $ shrinkList f

    shrinkHashMap' = shrinkHashMap shrinkNothing

    shrinkNamespace = do
      ns <- shrinkMaybe' _rscRootFieldsNamespace
      pure $ customization { _rscRootFieldsNamespace = ns }

    shrinkTypeNames = do
      tns <- shrinkMaybe shrinkTypeNames' _rscTypeNames
      pure $ customization { _rscTypeNames = tns}

    shrinkTypeNames' rtc@RemoteTypeCustomization{..} =
      (shrinkMaybe' _rtcPrefix <&> \p -> rtc { _rtcPrefix = p}) ++
      (shrinkMaybe' _rtcSuffix <&> \s -> rtc { _rtcSuffix = s}) ++
      (shrinkHashMap' _rtcMapping <&> \m -> rtc { _rtcMapping = m})

    shrinkFieldNames = do
      fns <- shrinkMaybe (shrinkList shrinkFieldNames') _rscFieldNames
      pure $ customization { _rscFieldNames = fns }

    shrinkFieldNames' rfc@RemoteFieldCustomization{..} =
      (shrinkMaybe' _rfcPrefix <&> \p -> rfc { _rfcPrefix = p}) ++
      (shrinkMaybe' _rfcSuffix <&> \s -> rfc { _rfcSuffix = s}) ++
      (shrinkHashMap' _rfcMapping <&> \m -> rfc { _rfcMapping = m})

    shrinkTypesAndFields = shrinkHashMap (traverse $ shrinkList shrinkNothing) typesAndFields

show_ :: (IntrospectionResult, HashMap G.Name [G.Name], RemoteSchemaCustomization) -> String
show_ (_a, b, c) = show (b, c)