prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Add basic output object type support

Browse Source
This commit is contained in:
Eugen Wissner 2020-05-14 09:17:14 +02:00
parent 4c19c88e98
commit a5c44f30fa
13 changed files with 231 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
CHANGELOG.md
View File

@ -13,6 +13,12 @@ and this project adheres to
execution. `FieldResolver` is executed in `ActionT` and the current `Field` is
passed in the reader and not as an explicit argument.
### Added
- `Type.Definition` and `Type.Schema` modules. Both contain the first types (but
not all yet) to describe a schema. Public functions that execute queries
accept a `Schema` now instead of a `HashMap`. The execution fails if the root
operation doesn't match the root Query type in the schema.
## [0.7.0.0] - 2020-05-11
### Fixed
- Result of null encoding

25
docs/tutorial/tutorial.lhs
View File

@ -17,14 +17,14 @@ 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)
>
> import Language.GraphQL
> import qualified Language.GraphQL.Schema as Schema
> import Language.GraphQL.Type.Definition
> import Language.GraphQL.Type.Schema
>
> import Prelude hiding (putStrLn)
@ -35,8 +35,11 @@ example from [graphql.js](https://github.com/graphql/graphql-js).
First we build a GraphQL schema.
> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO))
> schema1 = HashMap.singleton "Query" $ hello :| []
> schema1 :: Schema IO
> schema1 = Schema queryType Nothing
>
> queryType :: ObjectType IO
> queryType = ObjectType "Query" $ Schema.resolversToMap $ hello :| []
>
> hello :: Schema.Resolver IO
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
@ -65,8 +68,11 @@ returning
For this example, we're going to be using time.
> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO))
> schema2 = HashMap.singleton "Query" $ time :| []
> schema2 :: Schema IO
> schema2 = Schema queryType2 Nothing
>
> queryType2 :: ObjectType IO
> queryType2 = ObjectType "Query" $ Schema.resolversToMap $ time :| []
>
> time :: Schema.Resolver IO
> time = Schema.scalar "time" $ do
@ -124,8 +130,11 @@ This will fail
Now that we have two resolvers, we can define a schema which uses them both.
> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO))
> schema3 = HashMap.singleton "Query" $ hello :| [time]
> schema3 :: Schema IO
> schema3 = Schema queryType3 Nothing
>
> queryType3 :: ObjectType IO
> queryType3 = ObjectType "Query" $ Schema.resolversToMap $ hello :| [time]
>
> query3 :: Text
> query3 = "query timeAndHello { time hello }"

7
src/Language/GraphQL.hs
View File

@ -5,19 +5,18 @@ module Language.GraphQL
) where
import qualified Data.Aeson as Aeson
import Data.List.NonEmpty (NonEmpty)
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Language.GraphQL.Error
import Language.GraphQL.Execute
import Language.GraphQL.AST.Parser
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Type.Schema
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
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
=> Schema m -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response.
graphql = flip graphqlSubs mempty
@ -26,7 +25,7 @@ graphql = flip graphqlSubs mempty
-- applied to the query and the query is then executed using to the given
-- 'Schema.Resolver's.
graphqlSubs :: Monad m
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
=> Schema m -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function.
-> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response.

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

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
-- | This module provides functions to execute a @GraphQL@ request.
module Language.GraphQL.Execute
@ -7,10 +8,8 @@ module Language.GraphQL.Execute
) where
import qualified Data.Aeson as Aeson
import Data.Foldable (find)
import Data.List.NonEmpty (NonEmpty(..))
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
@ -18,6 +17,18 @@ import qualified Language.GraphQL.AST.Core as AST.Core
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Type.Definition
import Language.GraphQL.Type.Schema
-- | Query error types.
data QueryError
= OperationNotFound Text
| OperationNameRequired
queryError :: QueryError -> Text
queryError (OperationNotFound operationName) = Text.unwords
["Operation", operationName, "couldn't be found in the document."]
queryError OperationNameRequired = "Missing operation name."
-- | The substitution is applied to the document, and the resolvers are applied
-- to the resulting fields.
@ -25,7 +36,7 @@ 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
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
=> Schema m -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function.
-> Document -- @GraphQL@ document.
-> m Aeson.Value
@ -42,45 +53,55 @@ 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
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
=> Schema 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)
executeWithName schema operationName subs doc =
maybe transformError (document schema $ Just operationName)
$ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
getOperation
:: Maybe Text
-> AST.Core.Document
-> Either QueryError AST.Core.Operation
getOperation Nothing (operation' :| []) = pure operation'
getOperation Nothing _ = Left OperationNameRequired
getOperation (Just operationName) document'
| Just operation' <- find matchingName document' = pure operation'
| otherwise = Left $ OperationNotFound operationName
where
matchingName (AST.Core.Query (Just name') _) = operationName == name'
matchingName (AST.Core.Mutation (Just name') _) = operationName == name'
matchingName _ = False
document :: Monad m
=> HashMap Text (NonEmpty (Schema.Resolver m))
=> Schema m
-> Maybe Text
-> AST.Core.Document
-> m Aeson.Value
document schema Nothing (op :| []) = operation schema op
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
where
matchingName (AST.Core.Query (Just name') _) = name == name'
matchingName (AST.Core.Mutation (Just name') _) = name == name'
matchingName _ = False
document _ _ _ = return $ singleError "Missing operation name."
document schema operationName document' =
case getOperation operationName document' of
Left error' -> pure $ singleError $ queryError error'
Right operation' -> operation schema operation'
operation :: Monad m
=> HashMap Text (NonEmpty (Schema.Resolver m))
=> Schema m
-> AST.Core.Operation
-> m Aeson.Value
operation schema = schemaOperation
operation = schemaOperation
where
runResolver fields = runCollectErrs
. flip Schema.resolve fields
. Schema.resolversToMap
resolve fields queryType = maybe lookupError (runResolver fields)
$ HashMap.lookup queryType schema
resolve queryFields = runCollectErrs
. flip Schema.resolve queryFields
. fields
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"
schemaOperation Schema {query} (AST.Core.Query _ fields') =
resolve fields' query
schemaOperation Schema {mutation = Just mutation} (AST.Core.Mutation _ fields') =
resolve fields' mutation
schemaOperation Schema {mutation = Nothing} (AST.Core.Mutation _ _) =
lookupError

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

@ -3,7 +3,8 @@
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Schema
( Resolver(..)
( FieldResolver(..)
, Resolver(..)
, Subs
, object
, resolve

18
src/Language/GraphQL/Type/Definition.hs Normal file
View File

@ -0,0 +1,18 @@
module Language.GraphQL.Type.Definition
( ObjectType(..)
) where
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Language.GraphQL.Schema
type Fields m = HashMap Text (FieldResolver m)
-- | Object Type Definition.
--
-- Almost all of the GraphQL types you define will be object types. Object
-- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType
{ name :: Text
, fields :: Fields m
}

11
src/Language/GraphQL/Type/Schema.hs Normal file
View File

@ -0,0 +1,11 @@
module Language.GraphQL.Type.Schema
( Schema(..)
) where
import Language.GraphQL.Type.Definition
-- | Schema Definition
data Schema m = Schema
{ query :: ObjectType m
, mutation :: Maybe (ObjectType m)
}

36
tests/Test/DirectiveSpec.hs
View File

@ -5,18 +5,22 @@ 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 Language.GraphQL.Type.Definition
import Language.GraphQL.Type.Schema (Schema(..))
import Test.Hspec (Spec, describe, it, shouldBe)
import Text.RawString.QQ (r)
experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
experimentalResolver = HashMap.singleton "Query"
$ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
experimentalResolver :: Schema IO
experimentalResolver = Schema { query = queryType, mutation = Nothing }
where
queryType = ObjectType "Query"
$ HashMap.singleton "experimentalField"
$ Schema.ValueResolver
$ pure
$ Number 5
emptyObject :: Value
emptyObject = object
@ -27,17 +31,17 @@ spec :: Spec
spec =
describe "Directive executor" $ do
it "should be able to @skip fields" $ do
let query = [r|
let sourceQuery = [r|
{
experimentalField @skip(if: true)
}
|]
actual <- graphql experimentalResolver query
actual <- graphql experimentalResolver sourceQuery
actual `shouldBe` emptyObject
it "should not skip fields if @skip is false" $ do
let query = [r|
let sourceQuery = [r|
{
experimentalField @skip(if: false)
}
@ -48,21 +52,21 @@ spec =
]
]
actual <- graphql experimentalResolver query
actual <- graphql experimentalResolver sourceQuery
actual `shouldBe` expected
it "should skip fields if @include is false" $ do
let query = [r|
let sourceQuery = [r|
{
experimentalField @include(if: false)
}
|]
actual <- graphql experimentalResolver query
actual <- graphql experimentalResolver sourceQuery
actual `shouldBe` emptyObject
it "should be able to @skip a fragment spread" $ do
let query = [r|
let sourceQuery = [r|
{
...experimentalFragment @skip(if: true)
}
@ -72,11 +76,11 @@ spec =
}
|]
actual <- graphql experimentalResolver query
actual <- graphql experimentalResolver sourceQuery
actual `shouldBe` emptyObject
it "should be able to @skip an inline fragment" $ do
let query = [r|
let sourceQuery = [r|
{
... on ExperimentalType @skip(if: true) {
experimentalField
@ -84,5 +88,5 @@ spec =
}
|]
actual <- graphql experimentalResolver query
actual <- graphql experimentalResolver sourceQuery
actual `shouldBe` emptyObject

76
tests/Test/FragmentSpec.hs
View File

@ -10,13 +10,16 @@ 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
, shouldSatisfy
, shouldNotSatisfy
)
import Test.Hspec
( Spec
, describe
, it
, shouldBe
, shouldSatisfy
, shouldNotSatisfy
)
import Language.GraphQL.Type.Definition
import Language.GraphQL.Type.Schema
import Text.RawString.QQ (r)
size :: Schema.Resolver IO
@ -47,11 +50,18 @@ hasErrors :: Value -> Bool
hasErrors (Object object') = HashMap.member "errors" object'
hasErrors _ = True
toSchema :: Schema.Resolver IO -> Schema IO
toSchema resolver = Schema { query = queryType, mutation = Nothing }
where
queryType = ObjectType "Query"
$ Schema.resolversToMap
$ resolver :| []
spec :: Spec
spec = do
describe "Inline fragment executor" $ do
it "chooses the first selection if the type matches" $ do
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery
actual <- graphql (toSchema $ garment "Hat") inlineQuery
let expected = object
[ "data" .= object
[ "garment" .= object
@ -62,7 +72,7 @@ spec = do
in actual `shouldBe` expected
it "chooses the last selection if the type matches" $ do
actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery
actual <- graphql (toSchema $ garment "Shirt") inlineQuery
let expected = object
[ "data" .= object
[ "garment" .= object
@ -73,7 +83,7 @@ spec = do
in actual `shouldBe` expected
it "embeds inline fragments without type" $ do
let query = [r|{
let sourceQuery = [r|{
garment {
circumference
... {
@ -83,7 +93,7 @@ spec = do
}|]
resolvers = Schema.object "garment" $ return [circumference, size]
actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query
actual <- graphql (toSchema resolvers) sourceQuery
let expected = object
[ "data" .= object
[ "garment" .= object
@ -95,18 +105,18 @@ spec = do
in actual `shouldBe` expected
it "evaluates fragments on Query" $ do
let query = [r|{
let sourceQuery = [r|{
... {
size
}
}|]
actual <- graphql (HashMap.singleton "Query" $ size :| []) query
actual <- graphql (toSchema size) sourceQuery
actual `shouldNotSatisfy` hasErrors
describe "Fragment spread executor" $ do
it "evaluates fragment spreads" $ do
let query = [r|
let sourceQuery = [r|
{
...circumferenceFragment
}
@ -116,7 +126,7 @@ spec = do
}
|]
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
actual <- graphql (toSchema circumference) sourceQuery
let expected = object
[ "data" .= object
[ "circumference" .= (60 :: Int)
@ -125,7 +135,7 @@ spec = do
in actual `shouldBe` expected
it "evaluates nested fragments" $ do
let query = [r|
let sourceQuery = [r|
{
garment {
...circumferenceFragment
@ -141,7 +151,7 @@ spec = do
}
|]
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
actual <- graphql (toSchema $ garment "Hat") sourceQuery
let expected = object
[ "data" .= object
[ "garment" .= object
@ -152,7 +162,7 @@ spec = do
in actual `shouldBe` expected
it "rejects recursive fragments" $ do
let query = [r|
let sourceQuery = [r|
{
...circumferenceFragment
}
@ -162,11 +172,11 @@ spec = do
}
|]
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
actual <- graphql (toSchema circumference) sourceQuery
actual `shouldSatisfy` hasErrors
it "considers type condition" $ do
let query = [r|
let sourceQuery = [r|
{
garment {
...circumferenceFragment
@ -187,29 +197,5 @@ spec = do
]
]
]
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
actual <- graphql (toSchema $ garment "Hat") sourceQuery
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)

40
tests/Test/QuerySpec.hs
View File

@ -1,40 +0,0 @@
{-# 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)

62
tests/Test/RootOperationSpec.hs Normal file
View File

@ -0,0 +1,62 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.RootOperationSpec
( spec
) where
import Data.Aeson ((.=), object)
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)
import Language.GraphQL.Type.Definition
import Language.GraphQL.Type.Schema
schema :: Schema IO
schema = Schema
(ObjectType "Query" queryResolvers)
(Just $ ObjectType "Mutation" mutationResolvers)
where
queryResolvers = Schema.resolversToMap $ garment :| []
mutationResolvers = Schema.resolversToMap $ increment :| []
garment = Schema.object "garment" $ pure
[ Schema.scalar "circumference" $ pure (60 :: Int)
]
increment = Schema.scalar "incrementCircumference"
$ pure (61 :: Int)
spec :: Spec
spec =
describe "Root operation type" $ do
it "returns objects from the root resolvers" $ do
let querySource = [r|
{
garment {
circumference
}
}
|]
expected = object
[ "data" .= object
[ "garment" .= object
[ "circumference" .= (60 :: Int)
]
]
]
actual <- graphql schema querySource
actual `shouldBe` expected
it "chooses Mutation" $ do
let querySource = [r|
mutation {
incrementCircumference
}
|]
expected = object
[ "data" .= object
[ "incrementCircumference" .= (61 :: Int)
]
]
actual <- graphql schema querySource
actual `shouldBe` expected

8
tests/Test/StarWars/Data.hs
View File

@ -11,7 +11,7 @@ module Test.StarWars.Data
, getHuman
, id_
, homePlanet
, name
, name_
, secretBackstory
, typeName
) where
@ -55,9 +55,9 @@ id_ :: Character -> ID
id_ (Left x) = _id_ . _droidChar $ x
id_ (Right x) = _id_ . _humanChar $ x
name :: Character -> Text
name (Left x) = _name . _droidChar $ x
name (Right x) = _name . _humanChar $ x
name_ :: Character -> Text
name_ (Left x) = _name . _droidChar $ x
name_ (Right x) = _name . _humanChar $ x
friends :: Character -> [ID]
friends (Left x) = _friends . _droidChar $ x

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

@ -10,20 +10,23 @@ 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 Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type as Type
import Language.GraphQL.Type.Schema
import Test.StarWars.Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
schema = HashMap.singleton "Query" $ hero :| [human, droid]
schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing }
where
queryType = ObjectType "Query"
$ Schema.resolversToMap
$ hero :| [human, droid]
hero :: Schema.Resolver Identity
hero = Schema.object "hero" $ do
@ -55,7 +58,7 @@ droid = Schema.object "droid" $ do
character :: Character -> ActionT Identity [Schema.Resolver Identity]
character char = return
[ Schema.scalar "id" $ return $ id_ char
, Schema.scalar "name" $ return $ name char
, Schema.scalar "name" $ return $ name_ char
, Schema.wrappedObject "friends"
$ traverse character $ Type.List $ Type.Named <$> getFriends char
, Schema.wrappedScalar "appearsIn" $ return . Type.List