OSS
/
graphql
1
1
Fork 1
Code Issues 3 Pull Requests Actions Releases 22 Wiki Activity

Separate Query and Mutation resolvers 

Fixes #33 .
This commit is contained in:
Eugen Wissner 2020-05-10 18:32:58 +02:00
parent 387d158bd1
commit 500cff20eb
9 changed files with 94 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
CHANGELOG.md
View File

@ -17,7 +17,8 @@ and this project adheres to
- Type system definition parser.
- `Trans.argument`.
- Schema extension parser.
- Contributing guidelines
- Contributing guidelines.
- `Schema.resolversToMap` (intended for to be used internally).
### Changed
- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
@ -31,6 +32,12 @@ and this project adheres to
`symbol "@"` now.
- Replace `MonadIO` with a plain `Monad`. Since the tests don't use IO,
set the inner monad to `Identity`.
- `NonEmpty (Resolver m)` is now `HashMap Text (NonEmpty (Resolver m))`. Root
operation type can be any type, therefore a hashmap is needed. Since types
cannot be empty, we save the list of resolvers in the type as a non-empty
list. Currently only "Query" and "Mutation" are supported as types. For more
schema support is required. The executor checks now if the type in the query
matches the type of the provided root resolvers.
### Removed
- `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`.

14
docs/tutorial/tutorial.lhs
View File

@ -17,6 +17,8 @@ Since this file is a literate haskell file, we start by importing some dependenc
> import Control.Monad.IO.Class (liftIO)
> import Data.Aeson (encode)
> import Data.ByteString.Lazy.Char8 (putStrLn)
> import Data.HashMap.Strict (HashMap)
> import qualified Data.HashMap.Strict as HashMap
> import Data.List.NonEmpty (NonEmpty(..))
> import Data.Text (Text)
> import Data.Time (getCurrentTime)
@ -33,8 +35,8 @@ example from [graphql.js](https://github.com/graphql/graphql-js).
First we build a GraphQL schema.
> schema1 :: NonEmpty (Schema.Resolver IO)
> schema1 = hello :| []
> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO))
> schema1 = HashMap.singleton "Query" $ hello :| []
>
> hello :: Schema.Resolver IO
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
@ -63,8 +65,8 @@ returning
For this example, we're going to be using time.
> schema2 :: NonEmpty (Schema.Resolver IO)
> schema2 = time :| []
> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO))
> schema2 = HashMap.singleton "Query" $ time :| []
>
> time :: Schema.Resolver IO
> time = Schema.scalar "time" $ do
@ -122,8 +124,8 @@ This will fail
Now that we have two resolvers, we can define a schema which uses them both.
> schema3 :: NonEmpty (Schema.Resolver IO)
> schema3 = hello :| [time]
> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO))
> schema3 = HashMap.singleton "Query" $ hello :| [time]
>
> query3 :: Text
> query3 = "query timeAndHello { time hello }"

11
src/Language/GraphQL.hs
View File

@ -6,7 +6,8 @@ module Language.GraphQL
import qualified Data.Aeson as Aeson
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Text as T
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Language.GraphQL.Error
import Language.GraphQL.Execute
import Language.GraphQL.AST.Parser
@ -16,8 +17,8 @@ import Text.Megaparsec (parse)
-- | If the text parses correctly as a @GraphQL@ query the query is
-- executed using the given 'Schema.Resolver's.
graphql :: Monad m
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
-> T.Text -- ^ Text representing a @GraphQL@ request document.
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response.
graphql = flip graphqlSubs mempty
@ -25,9 +26,9 @@ graphql = flip graphqlSubs mempty
-- applied to the query and the query is then executed using to the given
-- 'Schema.Resolver's.
graphqlSubs :: Monad m
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function.
-> T.Text -- ^ Text representing a @GraphQL@ request document.
-> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response.
graphqlSubs schema f
= either parseError (execute schema f)

36
src/Language/GraphQL/Execute.hs
View File

@ -7,9 +7,10 @@ module Language.GraphQL.Execute
) where
import qualified Data.Aeson as Aeson
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import qualified Data.List.NonEmpty as NonEmpty
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Data.Text as Text
import Language.GraphQL.AST.Document
@ -24,12 +25,13 @@ import qualified Language.GraphQL.Schema as Schema
-- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field.
execute :: Monad m
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function.
-> Document -- @GraphQL@ document.
-> m Aeson.Value
execute schema subs doc =
maybe transformError (document schema Nothing) $ Transform.document subs doc
maybe transformError (document schema Nothing)
$ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
@ -40,23 +42,24 @@ execute schema subs doc =
-- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field.
executeWithName :: Monad m
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
-> Text -- ^ Operation name.
-> Schema.Subs -- ^ Variable substitution function.
-> Document -- ^ @GraphQL@ Document.
-> m Aeson.Value
executeWithName schema name subs doc =
maybe transformError (document schema $ Just name) $ Transform.document subs doc
maybe transformError (document schema $ Just name)
$ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
document :: Monad m
=> NonEmpty (Schema.Resolver m)
=> HashMap Text (NonEmpty (Schema.Resolver m))
-> Maybe Text
-> AST.Core.Document
-> m Aeson.Value
document schema Nothing (op :| []) = operation schema op
document schema (Just name) operations = case NE.dropWhile matchingName operations of
document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of
[] -> return $ singleError
$ Text.unwords ["Operation", name, "couldn't be found in the document."]
(op:_) -> operation schema op
@ -67,10 +70,17 @@ document schema (Just name) operations = case NE.dropWhile matchingName operatio
document _ _ _ = return $ singleError "Missing operation name."
operation :: Monad m
=> NonEmpty (Schema.Resolver m)
=> HashMap Text (NonEmpty (Schema.Resolver m))
-> AST.Core.Operation
-> m Aeson.Value
operation schema (AST.Core.Query _ flds)
= runCollectErrs (Schema.resolve (toList schema) flds)
operation schema (AST.Core.Mutation _ flds)
= runCollectErrs (Schema.resolve (toList schema) flds)
operation schema = schemaOperation
where
runResolver fields = runCollectErrs
. flip Schema.resolve fields
. Schema.resolversToMap
resolve fields queryType = maybe lookupError (runResolver fields)
$ HashMap.lookup queryType schema
lookupError = pure
$ singleError "Root operation type couldn't be found in the schema."
schemaOperation (AST.Core.Query _ fields) = resolve fields "Query"
schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation"

37
src/Language/GraphQL/Schema.hs
View File

@ -3,11 +3,12 @@
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Schema
( Resolver
( Resolver(..)
, Subs
, object
, scalar
, resolve
, resolversToMap
, scalar
, wrappedObject
, wrappedScalar
-- * AST Reexports
@ -18,7 +19,7 @@ module Language.GraphQL.Schema
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (find, fold)
import Data.Foldable (fold, toList)
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
@ -38,6 +39,15 @@ data Resolver m = Resolver
Text -- ^ Name
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
-- | Converts resolvers to a map.
resolversToMap
:: (Foldable f, Functor f)
=> f (Resolver m)
-> HashMap Text (Field -> CollectErrsT m Aeson.Object)
resolversToMap = HashMap.fromList . toList . fmap toKV
where
toKV (Resolver name f) = (name, f)
-- | Contains variables for the query. The key of the map is a variable name,
-- and the value is the variable value.
type Subs = HashMap Name Value
@ -46,7 +56,8 @@ type Subs = HashMap Name Value
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 resolver flds) fld
resolveRight fld@(Field _ _ _ flds) resolver
= withField (resolve (resolversToMap resolver) flds) fld
-- | Like 'object' but can be null or a list of objects.
wrappedObject ::
@ -57,7 +68,8 @@ wrappedObject ::
wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ sels) resolver
= withField (traverse (`resolve` sels) resolver) fld
= withField (traverse (resolveMap sels) resolver) fld
resolveMap = flip (resolve . 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
@ -81,7 +93,7 @@ wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
resolveFieldValue ::
Monad m =>
ActionT m a ->
(Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) ->
(Field -> a -> CollectErrsT m Aeson.Object) ->
Field ->
CollectErrsT m (HashMap Text Aeson.Value)
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
@ -103,22 +115,21 @@ withField v fld
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
resolve :: Monad m
=> [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
=> HashMap Text (Field -> CollectErrsT m Aeson.Object)
-> Seq Selection
-> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where
resolveTypeName (Resolver "__typename" f) = do
resolveTypeName f = do
value <- f $ Field Nothing "__typename" mempty mempty
return $ HashMap.lookupDefault "" "__typename" value
resolveTypeName _ = return ""
tryResolvers (SelectionField fld@(Field _ name _ _))
= maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
= fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers
if maybe True (Aeson.String typeCondition ==) that
then fmap fold . traverse tryResolvers $ selections'
else return mempty
compareResolvers name (Resolver name' _) = name == name'
tryResolver fld (Resolver _ resolver) = resolver fld
errmsg fld@(Field _ name _ _) = do
addErrMsg $ T.unwords ["field", name, "not resolved."]
return $ HashMap.singleton (aliasOrName fld) Aeson.Null

2
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: lts-15.7
resolver: lts-15.11
packages:
- .

18
tests/Test/DirectiveSpec.hs
View File

@ -5,14 +5,18 @@ module Test.DirectiveSpec
) where
import Data.Aeson (Value, object, (.=))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema
import Test.Hspec (Spec, describe, it, shouldBe)
import Text.RawString.QQ (r)
experimentalResolver :: Schema.Resolver IO
experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int)
experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
experimentalResolver = HashMap.singleton "Query"
$ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
emptyObject :: Value
emptyObject = object
@ -29,7 +33,7 @@ spec =
}
|]
actual <- graphql (experimentalResolver :| []) query
actual <- graphql experimentalResolver query
actual `shouldBe` emptyObject
it "should not skip fields if @skip is false" $ do
@ -44,7 +48,7 @@ spec =
]
]
actual <- graphql (experimentalResolver :| []) query
actual <- graphql experimentalResolver query
actual `shouldBe` expected
it "should skip fields if @include is false" $ do
@ -54,7 +58,7 @@ spec =
}
|]
actual <- graphql (experimentalResolver :| []) query
actual <- graphql experimentalResolver query
actual `shouldBe` emptyObject
it "should be able to @skip a fragment spread" $ do
@ -68,7 +72,7 @@ spec =
}
|]
actual <- graphql (experimentalResolver :| []) query
actual <- graphql experimentalResolver query
actual `shouldBe` emptyObject
it "should be able to @skip an inline fragment" $ do
@ -80,5 +84,5 @@ spec =
}
|]
actual <- graphql (experimentalResolver :| []) query
actual <- graphql experimentalResolver query
actual `shouldBe` emptyObject

16
tests/Test/FragmentSpec.hs
View File

@ -51,7 +51,7 @@ spec :: Spec
spec = do
describe "Inline fragment executor" $ do
it "chooses the first selection if the type matches" $ do
actual <- graphql (garment "Hat" :| []) inlineQuery
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery
let expected = object
[ "data" .= object
[ "garment" .= object
@ -62,7 +62,7 @@ spec = do
in actual `shouldBe` expected
it "chooses the last selection if the type matches" $ do
actual <- graphql (garment "Shirt" :| []) inlineQuery
actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery
let expected = object
[ "data" .= object
[ "garment" .= object
@ -83,7 +83,7 @@ spec = do
}|]
resolvers = Schema.object "garment" $ return [circumference, size]
actual <- graphql (resolvers :| []) query
actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query
let expected = object
[ "data" .= object
[ "garment" .= object
@ -101,7 +101,7 @@ spec = do
}
}|]
actual <- graphql (size :| []) query
actual <- graphql (HashMap.singleton "Query" $ size :| []) query
actual `shouldNotSatisfy` hasErrors
describe "Fragment spread executor" $ do
@ -116,7 +116,7 @@ spec = do
}
|]
actual <- graphql (circumference :| []) query
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
let expected = object
[ "data" .= object
[ "circumference" .= (60 :: Int)
@ -141,7 +141,7 @@ spec = do
}
|]
actual <- graphql (garment "Hat" :| []) query
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
let expected = object
[ "data" .= object
[ "garment" .= object
@ -162,7 +162,7 @@ spec = do
}
|]
actual <- graphql (circumference :| []) query
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
actual `shouldSatisfy` hasErrors
it "considers type condition" $ do
@ -187,5 +187,5 @@ spec = do
]
]
]
actual <- graphql (garment "Hat" :| []) query
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
actual `shouldBe` expected

7
tests/Test/StarWars/Schema.hs
View File

@ -10,8 +10,11 @@ module Test.StarWars.Schema
import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Class (lift)
import Data.Functor.Identity (Identity)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type as Type
@ -19,8 +22,8 @@ import Test.StarWars.Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
schema :: NonEmpty (Schema.Resolver Identity)
schema = hero :| [human, droid]
schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
schema = HashMap.singleton "Query" $ hero :| [human, droid]
hero :: Schema.Resolver Identity
hero = Schema.object "hero" $ do