diff --git a/graphql-api.cabal b/graphql-api.cabal index 5450b8b..78fdc39 100644 --- a/graphql-api.cabal +++ b/graphql-api.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 6db006b020fe198ac64b8a50f8335017251389b7c34dfc553675e38eb001a428 +-- hash: 24bc26dbd1f77e90690a71683ae20372d13f4729b6073940a17679e5bc18c609 name: graphql-api version: 0.3.0 @@ -133,6 +133,7 @@ test-suite graphql-api-tests build-depends: QuickCheck , aeson + , aeson-qq , attoparsec , base >=4.9 && <5 , containers @@ -144,6 +145,7 @@ test-suite graphql-api-tests , raw-strings-qq , tasty , tasty-hspec + , text , transformers other-modules: ASTTests diff --git a/package.yaml b/package.yaml index 1a922e9..47c4270 100644 --- a/package.yaml +++ b/package.yaml @@ -71,8 +71,10 @@ tests: - hspec - QuickCheck - raw-strings-qq + - aeson-qq - tasty - tasty-hspec + - text - directory graphql-api-doctests: diff --git a/src/GraphQL/Internal/Resolver.hs b/src/GraphQL/Internal/Resolver.hs index ca52f41..39f8665 100644 --- a/src/GraphQL/Internal/Resolver.hs +++ b/src/GraphQL/Internal/Resolver.hs @@ -53,8 +53,9 @@ import GraphQL.Value , FromValue(..) , ToValue(..) ) -import GraphQL.Internal.Name (Name, HasName(..)) +import GraphQL.Internal.Name (Name, HasName(..), unName) import qualified GraphQL.Internal.OrderedMap as OrderedMap +import GraphQL.Internal.Schema (ObjectTypeDefinition(..)) import GraphQL.Internal.Output (GraphQLError(..)) import GraphQL.Internal.Validation ( SelectionSetByType @@ -212,9 +213,16 @@ type family FieldName (a :: Type) = (r :: Symbol) where FieldName x = TypeError ('Text "Unexpected branch in FieldName type family. Please file a bug!" ':<>: 'ShowType x) resolveField :: forall dispatchType (m :: Type -> Type). - (BuildFieldResolver m dispatchType, Monad m, KnownSymbol (FieldName dispatchType)) - => FieldHandler m dispatchType -> m ResolveFieldResult -> Field Value -> m ResolveFieldResult -resolveField handler nextHandler field = + ( BuildFieldResolver m dispatchType + , Monad m + , KnownSymbol (FieldName dispatchType) + ) + => FieldHandler m dispatchType + -> m ResolveFieldResult + -> ObjectTypeDefinition + -> Field Value + -> m ResolveFieldResult +resolveField handler nextHandler defn field = -- check name before case API.nameFromSymbol @(FieldName dispatchType) of Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull)) @@ -225,6 +233,8 @@ resolveField handler nextHandler field = Right resolver -> do Result errs value <- resolver pure (Result errs (Just value)) + | getName field == "__typename" -> + pure $ Result [] (Just $ GValue.ValueString $ GValue.String $ unName $ getName defn) | otherwise -> nextHandler -- We're using our usual trick of rewriting a type in a closed type @@ -312,7 +322,6 @@ type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where RunFieldsHandler m a = TypeError ( 'Text "Unexpected RunFieldsHandler types: " ':<>: 'ShowType a) - class RunFields m a where -- | Run a single 'Selection' over all possible fields (as specified by the -- type @a@), returning exactly one 'GValue.ObjectField' when a field @@ -321,7 +330,7 @@ class RunFields m a where -- Individual implementations are responsible for calling 'runFields' if -- they haven't matched the field and there are still candidate fields -- within the handler. - runFields :: RunFieldsHandler m a -> Field Value -> m ResolveFieldResult + runFields :: RunFieldsHandler m a -> ObjectTypeDefinition -> Field Value -> m ResolveFieldResult instance forall f fs m dispatchType. ( BuildFieldResolver m dispatchType @@ -330,10 +339,10 @@ instance forall f fs m dispatchType. , KnownSymbol (FieldName dispatchType) , Monad m ) => RunFields m (f :<> fs) where - runFields (handler :<> nextHandlers) field = - resolveField @dispatchType @m handler nextHandler field + runFields (handler :<> nextHandlers) defn field = + resolveField @dispatchType @m handler nextHandler defn field where - nextHandler = runFields @m @fs nextHandlers field + nextHandler = runFields @m @fs nextHandlers defn field instance forall ksM t m dispatchType. ( BuildFieldResolver m dispatchType @@ -341,8 +350,8 @@ instance forall ksM t m dispatchType. , dispatchType ~ FieldResolverDispatchType (API.Field ksM t) , Monad m ) => RunFields m (API.Field ksM t) where - runFields handler field = - resolveField @dispatchType @m handler nextHandler field + runFields handler defn field = + resolveField @dispatchType @m handler nextHandler defn field where nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) @@ -352,8 +361,8 @@ instance forall m a b dispatchType. , KnownSymbol (FieldName dispatchType) , Monad m ) => RunFields m (a :> b) where - runFields handler field = - resolveField @dispatchType @m handler nextHandler field + runFields handler defn field = + resolveField @dispatchType @m handler nextHandler defn field where nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) @@ -368,12 +377,12 @@ instance forall typeName interfaces fields m. resolve mHandler (Just selectionSet) = case getSelectionSet of Left err -> throwE err - Right ss -> do + Right (ss, defn) -> do -- Run the handler so the field resolvers have access to the object. -- This (and other places, including field resolvers) is where user -- code can do things like look up something in a database. handler <- mHandler - r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss + r <- traverse (runFields @m @(RunFieldsType m fields) handler defn) ss let (Result errs obj) = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r pure (Result errs (GValue.ValueObject obj)) @@ -391,7 +400,7 @@ instance forall typeName interfaces fields m. -- See for -- more details. (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet - pure ss' + pure (ss', defn) -- TODO(tom): we're getting to a point where it might make sense to -- split resolver into submodules (GraphQL.Resolver.Union etc.) diff --git a/tests/ResolverTests.hs b/tests/ResolverTests.hs index 3ffdc7d..3bed108 100644 --- a/tests/ResolverTests.hs +++ b/tests/ResolverTests.hs @@ -1,14 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module ResolverTests (tests) where import Protolude hiding (Enum) +import Data.Aeson.QQ (aesonQQ) +import Text.RawString.QQ (r) import Test.Tasty (TestTree) import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) -import Data.Aeson (encode) +import Data.Aeson (encode, toJSON) import GraphQL ( Response(..) , interpretAnonymousQuery @@ -18,12 +21,14 @@ import GraphQL.API , Field , Argument , Enum + , Union , (:>) ) import GraphQL.Resolver ( Handler , ResolverError(..) , (:<>)(..) + , unionValue ) import GraphQL.Internal.Output (singleError) @@ -74,6 +79,28 @@ enumHandler :: Handler IO EnumQuery enumHandler = pure $ pure NormalFile -- /Enum test +-- Union test +type Cat = Object "Cat" '[] '[Field "name" Text] +type Dog = Object "Dog" '[] '[Field "name" Text] +type CatOrDog = Union "CatOrDog" '[Cat, Dog] +type UnionQuery = Object "UnionQuery" '[] + '[ Argument "isCat" Bool :> Field "catOrDog" CatOrDog + ] + +dogHandler :: Handler IO Cat +dogHandler = pure $ pure "Mortgage" + +catHandler :: Handler IO Dog +catHandler = pure $ pure "Felix" + +unionHandler :: Handler IO UnionQuery +unionHandler = pure $ \isCat -> + if isCat + then unionValue @Cat catHandler + else unionValue @Dog dogHandler + +-- /Union test + tests :: IO TestTree tests = testSpec "TypeAPI" $ do describe "tTest" $ do @@ -94,3 +121,47 @@ tests = testSpec "TypeAPI" $ do it "API.Enum works" $ do Success object <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }" encode object `shouldBe` "{\"mode\":\"NormalFile\"}" + + describe "Introspection" $ do + describe "__typename" $ do + it "can describe nested objects" $ do + Success object <- interpretAnonymousQuery @Query handler [r| + { + __typename + test(id: "1") { + __typename + name + } + } + |] + + toJSON object `shouldBe` [aesonQQ| + { + "__typename": "Query", + "test": { + "__typename": "Foo", + "name": "Mort" + } + } + |] + + it "can describe unions" $ do + Success object <- interpretAnonymousQuery @UnionQuery unionHandler [r| + { + __typename + catOrDog(isCat: false) { + __typename + name + } + } + |] + + toJSON object `shouldBe` [aesonQQ| + { + "__typename": "UnionQuery", + "catOrDog": { + "__typename": "Dog", + "name": "Mortgage" + } + } + |]