mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-15 09:22:43 +03:00
11a454c2d6
This commit applies ormolu to the whole Haskell code base by running `make format`. For in-flight branches, simply merging changes from `main` will result in merge conflicts. To avoid this, update your branch using the following instructions. Replace `<format-commit>` by the hash of *this* commit. $ git checkout my-feature-branch $ git merge <format-commit>^ # and resolve conflicts normally $ make format $ git commit -a -m "reformat with ormolu" $ git merge -s ours post-ormolu https://github.com/hasura/graphql-engine-mono/pull/2404 GitOrigin-RevId: 75049f5c12f430c615eafb4c6b8e83e371e01c8e
116 lines
5.3 KiB
Haskell
116 lines
5.3 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Hasura.GraphQL.RemoteServerSpec (spec) where
|
|
|
|
import Data.Containers.ListUtils (nubOrd)
|
|
import Data.Either (isRight)
|
|
import Data.HashMap.Strict qualified as Map
|
|
import Hasura.Generator ()
|
|
import Hasura.GraphQL.RemoteServer
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.Types.RemoteSchema
|
|
import Hasura.RQL.Types.SchemaCache
|
|
import Language.GraphQL.Draft.Syntax qualified as G
|
|
import Test.Hspec
|
|
import Test.Hspec.QuickCheck
|
|
import Test.QuickCheck
|
|
|
|
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)
|