From d7b6fd0329717ca8ae98db9993581ca493a3784f Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 5 Jul 2019 20:05:04 +0200 Subject: [PATCH] Allow resolvers to return arbitrary nested lists --- graphql.cabal | 3 +- src/Data/GraphQL/Schema.hs | 94 ++++++++++++++++------------------- src/Language/GraphQL/Type.hs | 57 +++++++++++++++++++++ tests/Test/StarWars/Schema.hs | 20 ++++---- 4 files changed, 113 insertions(+), 61 deletions(-) create mode 100644 src/Language/GraphQL/Type.hs diff --git a/graphql.cabal b/graphql.cabal index 04536c7..273080e 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 83313d55668f177f44fe72b0e590759e61e44093406bd0e7d41af66dd9199c92 +-- hash: 2f09ae8e288ccdea02b6f59bec6625b3f8795841f7ccf7cb19d1de428f0f63cb name: graphql version: 0.3 @@ -48,6 +48,7 @@ library Data.GraphQL.Schema Language.GraphQL.Lexer Language.GraphQL.Trans + Language.GraphQL.Type other-modules: Paths_graphql hs-source-dirs: diff --git a/src/Data/GraphQL/Schema.hs b/src/Data/GraphQL/Schema.hs index 943e552..56a9061 100644 --- a/src/Data/GraphQL/Schema.hs +++ b/src/Data/GraphQL/Schema.hs @@ -3,22 +3,22 @@ -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating Schemas. module Data.GraphQL.Schema - ( Schema - , Resolver + ( Resolver + , Schema , Subs - , nullableArray - , nullableEnum - , nullableObject - , nullableScalar , object , objectA , scalar , scalarA - , array - , arrayA , enum , enumA , resolve + , wrappedEnum + , wrappedEnumA + , wrappedObject + , wrappedObjectA + , wrappedScalar + , wrappedScalarA -- * AST Reexports , Field , Argument(..) @@ -40,6 +40,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Data.Text as T import Language.GraphQL.Trans +import Language.GraphQL.Type import Data.GraphQL.AST.Core -- | A GraphQL schema. @@ -70,14 +71,18 @@ objectA name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld --- | Like 'object' but can be null. -nullableObject :: MonadPlus m - => Name -> (Arguments -> ActionT m (Maybe [Resolver m])) -> Resolver m -nullableObject name f = Resolver name $ resolveFieldValue f resolveRight +-- | Like 'object' but also taking 'Argument's and can be null or a list of objects. +wrappedObjectA :: MonadPlus m + => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m +wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight where - resolveRight fld@(Field _ _ _ flds) (Just resolver) = withField (resolve resolver flds) fld - resolveRight fld Nothing - = return $ HashMap.singleton (aliasOrName fld) Aeson.Null + resolveRight fld@(Field _ _ _ sels) resolver + = withField (traverse (`resolve` sels) resolver) fld + +-- | Like 'object' but can be null or a list of objects. +wrappedObject :: MonadPlus m + => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m +wrappedObject name = wrappedObjectA name . const -- | A scalar represents a primitive value, like a string or an integer. scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m @@ -88,40 +93,22 @@ scalarA :: (MonadPlus m, Aeson.ToJSON a) => Name -> (Arguments -> ActionT m a) -> Resolver m scalarA name f = Resolver name $ resolveFieldValue f resolveRight where - resolveRight fld@(Field _ _ _ []) result = withField (return result) fld - resolveRight _ _ = mzero + resolveRight fld result = withField (return result) fld --- | Lika 'scalar' but can be null. -nullableScalar :: (MonadPlus m, Aeson.ToJSON a) - => Name -> (Arguments -> ActionT m (Maybe a)) -> Resolver m -nullableScalar name f = Resolver name $ resolveFieldValue f resolveRight +-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars. +wrappedScalarA :: (MonadPlus m, Aeson.ToJSON a) + => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m +wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight where - resolveRight fld@(Field _ _ _ []) (Just result) = withField (return result) fld - resolveRight fld Nothing + resolveRight fld (Named result) = withField (return result) fld + resolveRight fld Null = return $ HashMap.singleton (aliasOrName fld) Aeson.Null - resolveRight _ _ = mzero + resolveRight fld (List result) = withField (return result) fld --- | Creates a list of 'Resolver's. -array :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m -array name = arrayA name . const - --- | Like 'array' but also taking 'Argument's. -arrayA :: MonadPlus m - => Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m -arrayA name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld@(Field _ _ _ sels) resolver - = withField (traverse (`resolve` sels) resolver) fld - --- | Like 'array' but can be null. -nullableArray :: MonadPlus m - => Name -> (Arguments -> ActionT m (Maybe [[Resolver m]])) -> Resolver m -nullableArray name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld@(Field _ _ _ sels) (Just resolver) - = withField (traverse (`resolve` sels) resolver) fld - resolveRight fld Nothing - = return $ HashMap.singleton (aliasOrName fld) Aeson.Null +-- | Like 'scalar' but can be null or a list of scalars. +wrappedScalar :: (MonadPlus m, Aeson.ToJSON a) + => Name -> ActionT m (Wrapping a) -> Resolver m +wrappedScalar name = wrappedScalarA name . const -- | Represents one of a finite set of possible values. -- Used in place of a 'scalar' when the possible responses are easily enumerable. @@ -134,14 +121,19 @@ enumA name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld resolver = withField (return resolver) fld --- | Like 'array'' but also taking 'Argument's. -nullableEnum :: MonadPlus m - => Name -> (Arguments -> ActionT m (Maybe [Text])) -> Resolver m -nullableEnum name f = Resolver name $ resolveFieldValue f resolveRight +-- | Like 'enum' but also taking 'Argument's and can be null or a list of enums. +wrappedEnumA :: MonadPlus m + => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m +wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight where - resolveRight fld (Just resolver) = withField (return resolver) fld - resolveRight fld Nothing + resolveRight fld (Named resolver) = withField (return resolver) fld + resolveRight fld Null = return $ HashMap.singleton (aliasOrName fld) Aeson.Null + resolveRight fld (List resolver) = withField (return resolver) fld + +-- | Like 'enum' but can be null or a list of enums. +wrappedEnum :: MonadPlus m => Name -> ActionT m (Wrapping [Text]) -> Resolver m +wrappedEnum name = wrappedEnumA name . const resolveFieldValue :: MonadPlus m => ([Argument] -> ActionT m a) diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs new file mode 100644 index 0000000..3f91e50 --- /dev/null +++ b/src/Language/GraphQL/Type.hs @@ -0,0 +1,57 @@ +-- | Definitions for @GraphQL@ type system. +module Language.GraphQL.Type + ( Wrapping(..) + ) where + +import Data.Aeson as Aeson ( ToJSON + , toJSON + ) +import qualified Data.Aeson as Aeson + +-- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping +-- type can wrap other wrapping or named types. Wrapping types are lists and +-- Non-Null types (named types are nullable by default). +-- +-- This 'Wrapping' type doesn\'t reflect this distinction exactly but it is +-- used in the resolvers to take into account that the returned value can be +-- nullable or an (arbitrary nested) list. +data Wrapping a + = List [Wrapping a] -- ^ Arbitrary nested list + | Named a -- ^ Named type without further wrapping + | Null -- ^ Null + deriving (Eq, Show) + +instance Functor Wrapping where + fmap f (List list) = List $ fmap (fmap f) list + fmap f (Named named) = Named $ f named + fmap _ Null = Null + +instance Foldable Wrapping where + foldr f acc (List list) = foldr (flip $ foldr f) acc list + foldr f acc (Named named) = f named acc + foldr _ acc Null = acc + +instance Traversable Wrapping where + traverse f (List list) = List <$> traverse (traverse f) list + traverse f (Named named) = Named <$> f named + traverse _ Null = pure Null + +instance Applicative Wrapping where + pure = Named + Null <*> _ = Null + _ <*> Null = Null + (Named f) <*> (Named x) = Named $ f x + (List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs + (Named f) <*> list = f <$> list + (List fs) <*> named = List $ (<*> named) <$> fs + +instance Monad Wrapping where + return = pure + Null >>= _ = Null + (Named x) >>= f = f x + (List xs) >>= f = List $ fmap (>>= f) xs + +instance ToJSON a => ToJSON (Wrapping a) where + toJSON (List list) = toJSON list + toJSON (Named named) = toJSON named + toJSON Null = Aeson.Null diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index daa000e..13ec9fd 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -13,6 +13,7 @@ import Data.GraphQL.Schema ( Schema ) import qualified Data.GraphQL.Schema as Schema import Language.GraphQL.Trans +import Language.GraphQL.Type import Test.StarWars.Data -- * Schema @@ -30,12 +31,12 @@ hero = Schema.objectA "hero" $ \case _ -> ActionT $ throwE "Invalid arguments." human :: MonadPlus m => Resolver m -human = Schema.nullableObject "human" $ \case +human = Schema.wrappedObjectA "human" $ \case [Argument "id" (ValueString i)] -> do humanCharacter <- lift $ return $ getHuman i >>= Just case humanCharacter of - Nothing -> return Nothing - Just e -> Just <$> character e + Nothing -> return Null + Just e -> Named <$> character e _ -> ActionT $ throwE "Invalid arguments." droid :: MonadPlus m => Resolver m @@ -45,11 +46,12 @@ droid = Schema.objectA "droid" $ \case character :: MonadPlus m => Character -> ActionT m [Resolver m] character char = return - [ Schema.scalar "id" $ return $ id_ char - , Schema.scalar "name" $ return $ name char - , Schema.array "friends" $ traverse character $ getFriends char - , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char + [ Schema.scalar "id" $ return $ id_ char + , Schema.scalar "name" $ return $ name char + , Schema.wrappedObject "friends" + $ traverse character $ List $ Named <$> getFriends char + , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char , Schema.scalar "secretBackstory" $ secretBackstory char - , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char - , Schema.scalar "__typename" $ return $ typeName char + , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char + , Schema.scalar "__typename" $ return $ typeName char ]