diff --git a/CHANGELOG.md b/CHANGELOG.md index 03b0831..0f2012c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,11 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). ## [Unreleased] +### Changed +- `Resolver` is now `Resolver Name FieldResolver` where `FieldResolver` can + contain a JSON value or another resolver, which is invoked during the + execution. `FieldResolver` is executed in `ActionT` and the current `Field` is + passed in the reader and not as an explicit argument. ## [0.7.0.0] - 2020-05-11 ### Fixed @@ -20,7 +25,7 @@ and this project adheres to - `Trans.argument`. - Schema extension parser. - Contributing guidelines. -- `Schema.resolversToMap` (intended for to be used internally). +- `Schema.resolversToMap` (intended to be used internally). ### Changed - Rename `AST.Definition` into `AST.Document.ExecutableDefinition`. diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index c678e48..90a766c 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -35,18 +35,19 @@ import qualified Language.GraphQL.Type as Type -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error -- information (if an error has occurred). @m@ is an arbitrary monad, usually -- 'IO'. -data Resolver m = Resolver - Text -- ^ Name - (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver +data Resolver m = Resolver Name (FieldResolver m) + +data FieldResolver m + = ValueResolver (ActionT m Aeson.Value) + | NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m)))) -- | Converts resolvers to a map. -resolversToMap - :: (Foldable f, Functor f) +resolversToMap :: (Foldable f, Functor f) => f (Resolver m) - -> HashMap Text (Field -> CollectErrsT m Aeson.Object) + -> HashMap Text (FieldResolver m) resolversToMap = HashMap.fromList . toList . fmap toKV where - toKV (Resolver name f) = (name, f) + toKV (Resolver name r) = (name, r) -- | Contains variables for the query. The key of the map is a variable name, -- and the value is the variable value. @@ -54,85 +55,79 @@ type Subs = HashMap Name Value -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m -object name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld@(Field _ _ _ flds) resolver - = withField (resolve (resolversToMap resolver) flds) fld +object name = Resolver name + . NestingResolver + . fmap (Type.Named . resolversToMap) -- | Like 'object' but can be null or a list of objects. -wrappedObject :: - Monad m => - Name -> - ActionT m (Type.Wrapping [Resolver m]) -> - Resolver m -wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld@(Field _ _ _ sels) resolver - = withField (traverse (resolveMap sels) resolver) fld - resolveMap = flip (resolve . resolversToMap) +wrappedObject :: Monad m + => Name + -> ActionT m (Type.Wrapping [Resolver m]) + -> Resolver m +wrappedObject name = Resolver name + . NestingResolver + . (fmap . fmap) resolversToMap -- | A scalar represents a primitive value, like a string or an integer. scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m -scalar name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld result = withField (return result) fld +scalar name = Resolver name . ValueResolver . fmap Aeson.toJSON -- | Like 'scalar' but can be null or a list of scalars. -wrappedScalar :: - (Monad m, Aeson.ToJSON a) => - Name -> - ActionT m (Type.Wrapping a) -> - Resolver m -wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld (Type.Named result) = withField (return result) fld - resolveRight fld Type.Null - = return $ HashMap.singleton (aliasOrName fld) Aeson.Null - resolveRight fld (Type.List result) = withField (return result) fld +wrappedScalar :: (Monad m, Aeson.ToJSON a) + => Name + -> ActionT m (Type.Wrapping a) + -> Resolver m +wrappedScalar name = Resolver name . ValueResolver . fmap Aeson.toJSON -resolveFieldValue :: - Monad m => - ActionT m a -> - (Field -> a -> CollectErrsT m Aeson.Object) -> - Field -> - CollectErrsT m (HashMap Text Aeson.Value) -resolveFieldValue f resolveRight fld@(Field _ _ args _) = do - result <- lift $ reader . runExceptT . runActionT $ f - either resolveLeft (resolveRight fld) result - where - reader = flip runReaderT $ Context {arguments=args} - resolveLeft err = do - _ <- addErrMsg err - return $ HashMap.singleton (aliasOrName fld) Aeson.Null +resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a) +resolveFieldValue field@(Field _ _ args _) = + flip runReaderT (Context {arguments=args, info=field}) + . runExceptT + . runActionT --- | Helper function to facilitate error handling and result emitting. -withField :: (Monad m, Aeson.ToJSON a) - => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) -withField v fld - = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v +convert :: Type.Wrapping Aeson.Value -> Aeson.Value +convert Type.Null = Aeson.Null +convert (Type.Named value) = value +convert (Type.List value) = Aeson.toJSON value + +withField :: Monad m => Field -> FieldResolver m -> CollectErrsT m Aeson.Object +withField field (ValueResolver resolver) = do + answer <- lift $ resolveFieldValue field resolver + either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer +withField field@(Field _ _ _ seqSelection) (NestingResolver resolver) = do + answer <- lift $ resolveFieldValue field resolver + case answer of + Right result -> do + nestedFields <- traverse (`resolve` seqSelection) result + pure $ HashMap.singleton (aliasOrName field) $ convert nestedFields + Left errorMessage -> errmsg field errorMessage + +errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value) +errmsg field errorMessage = do + addErrMsg errorMessage + pure $ HashMap.singleton (aliasOrName field) Aeson.Null -- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. resolve :: Monad m - => HashMap Text (Field -> CollectErrsT m Aeson.Object) + => HashMap Text (FieldResolver m) -> Seq Selection -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers where - resolveTypeName f = do - value <- f $ Field Nothing "__typename" mempty mempty - return $ HashMap.lookupDefault "" "__typename" value + lookupResolver = flip HashMap.lookup resolvers tryResolvers (SelectionField fld@(Field _ name _ _)) - = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld - tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do - that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers - if maybe True (Aeson.String typeCondition ==) that - then fmap fold . traverse tryResolvers $ selections' - else return mempty - errmsg fld@(Field _ name _ _) = do - addErrMsg $ T.unwords ["field", name, "not resolved."] - return $ HashMap.singleton (aliasOrName fld) Aeson.Null + | (Just resolver) <- lookupResolver name = withField fld resolver + | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."] + tryResolvers (SelectionFragment (Fragment typeCondition selections')) + | Just (ValueResolver resolver) <- lookupResolver "__typename" = do + let fakeField = Field Nothing "__typename" mempty mempty + that <- lift $ resolveFieldValue fakeField resolver + if Right (Aeson.String typeCondition) == that + then fmap fold . traverse tryResolvers $ selections' + else pure mempty + | otherwise = fmap fold . traverse tryResolvers $ selections' aliasOrName :: Field -> Text aliasOrName (Field alias name _ _) = fromMaybe name alias diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index 09c012b..f09a8a0 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -18,8 +18,9 @@ import Language.GraphQL.AST.Core import Prelude hiding (lookup) -- | Resolution context holds resolver arguments. -newtype Context = Context +data Context = Context { arguments :: Arguments + , info :: Field } -- | Monad transformer stack used by the resolvers to provide error handling diff --git a/tests/Language/GraphQL/SchemaSpec.hs b/tests/Language/GraphQL/SchemaSpec.hs new file mode 100644 index 0000000..6804150 --- /dev/null +++ b/tests/Language/GraphQL/SchemaSpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.GraphQL.SchemaSpec + ( spec + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Sequence as Sequence +import Data.Text (Text) +import Language.GraphQL.AST.Core +import Language.GraphQL.Error +import Language.GraphQL.Schema +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = + describe "resolve" $ + it "ignores invalid __typename" $ do + let resolver = object "__typename" $ pure + [ scalar "field" $ pure ("T" :: Text) + ] + schema = resolversToMap [resolver] + fields = Sequence.singleton + $ SelectionFragment + $ Fragment "T" Sequence.empty + expected = Aeson.object + [ ("data" , Aeson.emptyObject) + ] + + actual <- runCollectErrs (resolve schema fields) + actual `shouldBe` expected diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 3b9da19..b4cf364 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -4,7 +4,7 @@ module Test.DirectiveSpec ( spec ) where -import Data.Aeson (Value, object, (.=)) +import Data.Aeson (Value(..), object, (.=)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty(..)) diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 74293a9..99c0715 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -189,3 +189,27 @@ spec = do ] actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query actual `shouldBe` expected + + it "test1" $ do + let query = [r| + { + garment { + circumference + } + } + |] + expected = object + [ "data" .= object + [ "garment" .= object + [ "circumference" .= (60 :: Int) + ] + ] + ] + actual <- graphql schema query + actual `shouldBe` expected + where + schema = HashMap.singleton "Query" $ garment' :| [] + garment' = Schema.object "garment" $ return + [ circumference' + ] + circumference' = Schema.scalar "circumference" $ pure (60 :: Int) diff --git a/tests/Test/QuerySpec.hs b/tests/Test/QuerySpec.hs new file mode 100644 index 0000000..95608b0 --- /dev/null +++ b/tests/Test/QuerySpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Test.QuerySpec + ( spec + ) where + +import Data.Aeson ((.=), object) +import qualified Data.HashMap.Strict as HashMap +import Data.List.NonEmpty (NonEmpty(..)) +import Language.GraphQL +import qualified Language.GraphQL.Schema as Schema +import Test.Hspec (Spec, describe, it, shouldBe) +import Text.RawString.QQ (r) + +spec :: Spec +spec = + describe "Query executor" $ + it "returns objects from the root resolvers" $ do + let query = [r| + { + garment { + circumference + } + } + |] + expected = object + [ "data" .= object + [ "garment" .= object + [ "circumference" .= (60 :: Int) + ] + ] + ] + actual <- graphql schema query + actual `shouldBe` expected + where + schema = HashMap.singleton "Query" $ garment' :| [] + garment' = Schema.object "garment" $ return + [ circumference' + ] + circumference' = Schema.scalar "circumference" $ pure (60 :: Int)