Compare commits
18 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | aef6030a8e | |
Eugen Wissner | 91bd2d0d81 | |
Eugen Wissner | 882276a845 | |
Eugen Wissner | e8c54810f8 | |
Eugen Wissner | c37b9c88b1 | |
Eugen Wissner | fdb1268213 | |
Eugen Wissner | 377c87045e | |
Eugen Wissner | 4c9264c12c | |
Eugen Wissner | 93a0403288 | |
Eugen Wissner | d12577ae71 | |
Eugen Wissner | c06d0b8e95 | |
Eugen Wissner | 61dbe6c728 | |
Eugen Wissner | eb90a4091c | |
Eugen Wissner | 7cd4821718 | |
Eugen Wissner | 26cc53ce06 | |
Eugen Wissner | c3ecfece03 | |
Eugen Wissner | a5c44f30fa | |
Eugen Wissner | 4c19c88e98 |
58
CHANGELOG.md
58
CHANGELOG.md
|
@ -6,7 +6,59 @@ The format is based on
|
||||||
and this project adheres to
|
and this project adheres to
|
||||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||||
|
|
||||||
## [Unreleased]
|
## [0.8.0.0] - 2020-06-20
|
||||||
|
### Fixed
|
||||||
|
- The parser rejects variables when parsing defaultValue (DefaultValue). The
|
||||||
|
specification defines default values as `Value` with `const` parameter and
|
||||||
|
constants cannot be variables. `AST.Document.ConstValue` was added,
|
||||||
|
`AST.Document.ObjectField` was modified.
|
||||||
|
- AST transformation should never fail.
|
||||||
|
* Arguments and fields with a missing variable as value should be left out.
|
||||||
|
* Invalid (recusrive or non-existing) fragments should be skipped.
|
||||||
|
- Argument value coercion.
|
||||||
|
- Variable value coercion.
|
||||||
|
- Result coercion.
|
||||||
|
- The executor should skip the fields missing in the object type and not fail.
|
||||||
|
- Merging subselections.
|
||||||
|
|
||||||
|
### Changed
|
||||||
|
- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function
|
||||||
|
pair.
|
||||||
|
- `AST.Core.Value` was moved into `Type.Definition`. These values are used only
|
||||||
|
in the execution and type system, it is not a part of the parsing tree.
|
||||||
|
- `Type` module is superseded by `Type.Out`. This module contains now only
|
||||||
|
exports from other module that complete `Type.In` and `Type.Out` exports.
|
||||||
|
- `Error.CollectErrsT` contains the new `Resolution` data structure.
|
||||||
|
`Resolution` represents the state used by the executor. It contains all types
|
||||||
|
defined in the schema and collects the thrown errors.
|
||||||
|
|
||||||
|
### Added
|
||||||
|
- `Type.Definition` contains base type system definition, e.g. Enums and
|
||||||
|
Scalars.
|
||||||
|
- `Type.Schema` describes a schema. Both 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.
|
||||||
|
- `Type.In` and `Type.Out` contain definitions for input and output types.
|
||||||
|
- `Execute.Coerce` defines a typeclass responsible for input, variable value
|
||||||
|
coercion. It decouples us a bit from JSON since any format can be used to pass
|
||||||
|
query variables. Execution functions accept (`HashMap Name a`) instead of
|
||||||
|
`Subs`, where a is an instance of `VariableValue`.
|
||||||
|
|
||||||
|
### Removed
|
||||||
|
- `Schema.scalar`, `Schema.wrappedScalar`. They accepted everything can be
|
||||||
|
converted to JSON and JSON is not suitable as an internal representation for
|
||||||
|
GraphQL. E.g. GraphQL distinguishes between Floats and Integers.
|
||||||
|
- `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no
|
||||||
|
need in special functions to construct field resolvers anymore, resolvers are
|
||||||
|
normal functions attached to the fields in the schema representation.
|
||||||
|
- `Schema.resolve` is superseded by `Execute.Execution`.
|
||||||
|
- `Error.runAppendErrs` isn't used anywhere.
|
||||||
|
- `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias`
|
||||||
|
`TypeCondition` were modified, moved into `Execute.Transform.Document` and
|
||||||
|
made private. These types describe intermediate representation used by the
|
||||||
|
executor internally. Moving was required to avoid cyclic dependencies between
|
||||||
|
the executor and type system.
|
||||||
|
- `AST.Core` doesn't reexports anything.
|
||||||
|
|
||||||
## [0.7.0.0] - 2020-05-11
|
## [0.7.0.0] - 2020-05-11
|
||||||
### Fixed
|
### Fixed
|
||||||
|
@ -20,7 +72,7 @@ and this project adheres to
|
||||||
- `Trans.argument`.
|
- `Trans.argument`.
|
||||||
- Schema extension parser.
|
- Schema extension parser.
|
||||||
- Contributing guidelines.
|
- Contributing guidelines.
|
||||||
- `Schema.resolversToMap` (intended for to be used internally).
|
- `Schema.resolversToMap` (intended to be used internally).
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
|
- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
|
||||||
|
@ -215,7 +267,7 @@ and this project adheres to
|
||||||
### Added
|
### Added
|
||||||
- Data types for the GraphQL language.
|
- Data types for the GraphQL language.
|
||||||
|
|
||||||
[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD
|
[0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0
|
||||||
[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0
|
[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0
|
||||||
[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
|
[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
|
||||||
[0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0
|
[0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0
|
||||||
|
|
|
@ -17,14 +17,15 @@ Since this file is a literate haskell file, we start by importing some dependenc
|
||||||
> import Control.Monad.IO.Class (liftIO)
|
> import Control.Monad.IO.Class (liftIO)
|
||||||
> import Data.Aeson (encode)
|
> import Data.Aeson (encode)
|
||||||
> import Data.ByteString.Lazy.Char8 (putStrLn)
|
> import Data.ByteString.Lazy.Char8 (putStrLn)
|
||||||
> import Data.HashMap.Strict (HashMap)
|
|
||||||
> import qualified Data.HashMap.Strict as HashMap
|
> import qualified Data.HashMap.Strict as HashMap
|
||||||
> import Data.List.NonEmpty (NonEmpty(..))
|
|
||||||
> import Data.Text (Text)
|
> import Data.Text (Text)
|
||||||
|
> import qualified Data.Text as Text
|
||||||
> import Data.Time (getCurrentTime)
|
> import Data.Time (getCurrentTime)
|
||||||
>
|
>
|
||||||
> import Language.GraphQL
|
> import Language.GraphQL
|
||||||
> import qualified Language.GraphQL.Schema as Schema
|
> import Language.GraphQL.Trans
|
||||||
|
> import Language.GraphQL.Type
|
||||||
|
> import qualified Language.GraphQL.Type.Out as Out
|
||||||
>
|
>
|
||||||
> import Prelude hiding (putStrLn)
|
> import Prelude hiding (putStrLn)
|
||||||
|
|
||||||
|
@ -35,11 +36,19 @@ example from [graphql.js](https://github.com/graphql/graphql-js).
|
||||||
|
|
||||||
First we build a GraphQL schema.
|
First we build a GraphQL schema.
|
||||||
|
|
||||||
> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
> schema1 :: Schema IO
|
||||||
> schema1 = HashMap.singleton "Query" $ hello :| []
|
> schema1 = Schema queryType Nothing
|
||||||
>
|
>
|
||||||
> hello :: Schema.Resolver IO
|
> queryType :: ObjectType IO
|
||||||
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
|
> queryType = ObjectType "Query" Nothing []
|
||||||
|
> $ HashMap.singleton "hello"
|
||||||
|
> $ Out.Resolver helloField hello
|
||||||
|
>
|
||||||
|
> helloField :: Field IO
|
||||||
|
> helloField = Field Nothing (Out.NamedScalarType string) mempty
|
||||||
|
>
|
||||||
|
> hello :: ActionT IO Value
|
||||||
|
> hello = pure $ String "it's me"
|
||||||
|
|
||||||
This defines a simple schema with one type and one field, that resolves to a fixed value.
|
This defines a simple schema with one type and one field, that resolves to a fixed value.
|
||||||
|
|
||||||
|
@ -52,7 +61,7 @@ Next we define our query.
|
||||||
To run the query, we call the `graphql` with the schema and the query.
|
To run the query, we call the `graphql` with the schema and the query.
|
||||||
|
|
||||||
> main1 :: IO ()
|
> main1 :: IO ()
|
||||||
> main1 = putStrLn =<< encode <$> graphql schema1 query1
|
> main1 = graphql schema1 query1 >>= putStrLn . encode
|
||||||
|
|
||||||
This runs the query by fetching the one field defined,
|
This runs the query by fetching the one field defined,
|
||||||
returning
|
returning
|
||||||
|
@ -65,13 +74,21 @@ returning
|
||||||
|
|
||||||
For this example, we're going to be using time.
|
For this example, we're going to be using time.
|
||||||
|
|
||||||
> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
> schema2 :: Schema IO
|
||||||
> schema2 = HashMap.singleton "Query" $ time :| []
|
> schema2 = Schema queryType2 Nothing
|
||||||
>
|
>
|
||||||
> time :: Schema.Resolver IO
|
> queryType2 :: ObjectType IO
|
||||||
> time = Schema.scalar "time" $ do
|
> queryType2 = ObjectType "Query" Nothing []
|
||||||
|
> $ HashMap.singleton "time"
|
||||||
|
> $ Out.Resolver timeField time
|
||||||
|
>
|
||||||
|
> timeField :: Field IO
|
||||||
|
> timeField = Field Nothing (Out.NamedScalarType string) mempty
|
||||||
|
>
|
||||||
|
> time :: ActionT IO Value
|
||||||
|
> time = do
|
||||||
> t <- liftIO getCurrentTime
|
> t <- liftIO getCurrentTime
|
||||||
> return $ show t
|
> pure $ String $ Text.pack $ show t
|
||||||
|
|
||||||
This defines a simple schema with one type and one field,
|
This defines a simple schema with one type and one field,
|
||||||
which resolves to the current time.
|
which resolves to the current time.
|
||||||
|
@ -82,7 +99,7 @@ Next we define our query.
|
||||||
> query2 = "{ time }"
|
> query2 = "{ time }"
|
||||||
>
|
>
|
||||||
> main2 :: IO ()
|
> main2 :: IO ()
|
||||||
> main2 = putStrLn =<< encode <$> graphql schema2 query2
|
> main2 = graphql schema2 query2 >>= putStrLn . encode
|
||||||
|
|
||||||
This runs the query, returning the current time
|
This runs the query, returning the current time
|
||||||
|
|
||||||
|
@ -124,14 +141,20 @@ This will fail
|
||||||
|
|
||||||
Now that we have two resolvers, we can define a schema which uses them both.
|
Now that we have two resolvers, we can define a schema which uses them both.
|
||||||
|
|
||||||
> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
> schema3 :: Schema IO
|
||||||
> schema3 = HashMap.singleton "Query" $ hello :| [time]
|
> schema3 = Schema queryType3 Nothing
|
||||||
|
>
|
||||||
|
> queryType3 :: ObjectType IO
|
||||||
|
> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||||
|
> [ ("hello", Out.Resolver helloField hello)
|
||||||
|
> , ("time", Out.Resolver timeField time)
|
||||||
|
> ]
|
||||||
>
|
>
|
||||||
> query3 :: Text
|
> query3 :: Text
|
||||||
> query3 = "query timeAndHello { time hello }"
|
> query3 = "query timeAndHello { time hello }"
|
||||||
>
|
>
|
||||||
> main3 :: IO ()
|
> main3 :: IO ()
|
||||||
> main3 = putStrLn =<< encode <$> graphql schema3 query3
|
> main3 = graphql schema3 query3 >>= putStrLn . encode
|
||||||
|
|
||||||
This queries for both time and hello, returning
|
This queries for both time and hello, returning
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 0.7.0.0
|
version: 0.8.0.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description:
|
description:
|
||||||
This package provides a rudimentary parser for the
|
This package provides a rudimentary parser for the
|
||||||
|
@ -31,15 +31,20 @@ dependencies:
|
||||||
- containers
|
- containers
|
||||||
- megaparsec
|
- megaparsec
|
||||||
- parser-combinators
|
- parser-combinators
|
||||||
|
- scientific
|
||||||
- text
|
- text
|
||||||
- transformers
|
- transformers
|
||||||
- unordered-containers
|
- unordered-containers
|
||||||
|
- vector
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
other-modules:
|
other-modules:
|
||||||
|
- Language.GraphQL.Execute.Execution
|
||||||
- Language.GraphQL.Execute.Transform
|
- Language.GraphQL.Execute.Transform
|
||||||
|
- Language.GraphQL.Type.Definition
|
||||||
- Language.GraphQL.Type.Directive
|
- Language.GraphQL.Type.Directive
|
||||||
|
- Language.GraphQL.Type.Schema
|
||||||
|
|
||||||
tests:
|
tests:
|
||||||
tasty:
|
tasty:
|
||||||
|
|
|
@ -5,29 +5,30 @@ module Language.GraphQL
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Language.GraphQL.AST.Document
|
||||||
|
import Language.GraphQL.AST.Parser
|
||||||
import Language.GraphQL.Error
|
import Language.GraphQL.Error
|
||||||
import Language.GraphQL.Execute
|
import Language.GraphQL.Execute
|
||||||
import Language.GraphQL.AST.Parser
|
import Language.GraphQL.Execute.Coerce
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
import Language.GraphQL.Type.Schema
|
||||||
import Text.Megaparsec (parse)
|
import Text.Megaparsec (parse)
|
||||||
|
|
||||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||||
-- executed using the given 'Schema.Resolver's.
|
-- executed using the given 'Schema'.
|
||||||
graphql :: Monad m
|
graphql :: Monad m
|
||||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
=> Schema m -- ^ Resolvers.
|
||||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||||
-> m Aeson.Value -- ^ Response.
|
-> m Aeson.Value -- ^ Response.
|
||||||
graphql = flip graphqlSubs mempty
|
graphql = flip graphqlSubs (mempty :: Aeson.Object)
|
||||||
|
|
||||||
-- | If the text parses correctly as a @GraphQL@ query the substitution is
|
-- | If the text parses correctly as a @GraphQL@ query the substitution is
|
||||||
-- applied to the query and the query is then executed using to the given
|
-- applied to the query and the query is then executed using to the given
|
||||||
-- 'Schema.Resolver's.
|
-- 'Schema'.
|
||||||
graphqlSubs :: Monad m
|
graphqlSubs :: (Monad m, VariableValue a)
|
||||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
=> Schema m -- ^ Resolvers.
|
||||||
-> Schema.Subs -- ^ Variable substitution function.
|
-> HashMap Name a -- ^ Variable substitution function.
|
||||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||||
-> m Aeson.Value -- ^ Response.
|
-> m Aeson.Value -- ^ Response.
|
||||||
graphqlSubs schema f
|
graphqlSubs schema f
|
||||||
|
|
|
@ -1,41 +1,11 @@
|
||||||
-- | This is the AST meant to be executed.
|
-- | This is the AST meant to be executed.
|
||||||
module Language.GraphQL.AST.Core
|
module Language.GraphQL.AST.Core
|
||||||
( Alias
|
( Arguments(..)
|
||||||
, Arguments(..)
|
|
||||||
, Directive(..)
|
|
||||||
, Document
|
|
||||||
, Field(..)
|
|
||||||
, Fragment(..)
|
|
||||||
, Name
|
|
||||||
, Operation(..)
|
|
||||||
, Selection(..)
|
|
||||||
, TypeCondition
|
|
||||||
, Value(..)
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Int (Int32)
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Language.GraphQL.AST (Name)
|
||||||
import Data.Sequence (Seq)
|
import Language.GraphQL.Type.Definition
|
||||||
import Data.String (IsString(..))
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Language.GraphQL.AST (Alias, Name, TypeCondition)
|
|
||||||
|
|
||||||
-- | GraphQL document is a non-empty list of operations.
|
|
||||||
type Document = NonEmpty Operation
|
|
||||||
|
|
||||||
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
|
|
||||||
--
|
|
||||||
-- Currently only queries and mutations are supported.
|
|
||||||
data Operation
|
|
||||||
= Query (Maybe Text) (Seq Selection)
|
|
||||||
| Mutation (Maybe Text) (Seq Selection)
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Single GraphQL field.
|
|
||||||
data Field
|
|
||||||
= Field (Maybe Alias) Name Arguments (Seq Selection)
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Argument list.
|
-- | Argument list.
|
||||||
newtype Arguments = Arguments (HashMap Name Value)
|
newtype Arguments = Arguments (HashMap Name Value)
|
||||||
|
@ -47,32 +17,3 @@ instance Semigroup Arguments where
|
||||||
instance Monoid Arguments where
|
instance Monoid Arguments where
|
||||||
mempty = Arguments mempty
|
mempty = Arguments mempty
|
||||||
|
|
||||||
-- | Directive.
|
|
||||||
data Directive = Directive Name Arguments
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Represents fragments and inline fragments.
|
|
||||||
data Fragment
|
|
||||||
= Fragment TypeCondition (Seq Selection)
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Single selection element.
|
|
||||||
data Selection
|
|
||||||
= SelectionFragment Fragment
|
|
||||||
| SelectionField Field
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Represents accordingly typed GraphQL values.
|
|
||||||
data Value
|
|
||||||
= Int Int32
|
|
||||||
| Float Double -- ^ GraphQL Float is double precision
|
|
||||||
| String Text
|
|
||||||
| Boolean Bool
|
|
||||||
| Null
|
|
||||||
| Enum Name
|
|
||||||
| List [Value]
|
|
||||||
| Object (HashMap Name Value)
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
instance IsString Value where
|
|
||||||
fromString = String . fromString
|
|
||||||
|
|
|
@ -8,6 +8,7 @@ module Language.GraphQL.AST.Document
|
||||||
( Alias
|
( Alias
|
||||||
, Argument(..)
|
, Argument(..)
|
||||||
, ArgumentsDefinition(..)
|
, ArgumentsDefinition(..)
|
||||||
|
, ConstValue(..)
|
||||||
, Definition(..)
|
, Definition(..)
|
||||||
, Description(..)
|
, Description(..)
|
||||||
, Directive(..)
|
, Directive(..)
|
||||||
|
@ -197,7 +198,7 @@ type TypeCondition = Name
|
||||||
|
|
||||||
-- ** Input Values
|
-- ** Input Values
|
||||||
|
|
||||||
-- | Input value.
|
-- | Input value (literal or variable).
|
||||||
data Value
|
data Value
|
||||||
= Variable Name
|
= Variable Name
|
||||||
| Int Int32
|
| Int Int32
|
||||||
|
@ -207,18 +208,46 @@ data Value
|
||||||
| Null
|
| Null
|
||||||
| Enum Name
|
| Enum Name
|
||||||
| List [Value]
|
| List [Value]
|
||||||
| Object [ObjectField]
|
| Object [ObjectField Value]
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- | Constant input value.
|
||||||
|
data ConstValue
|
||||||
|
= ConstInt Int32
|
||||||
|
| ConstFloat Double
|
||||||
|
| ConstString Text
|
||||||
|
| ConstBoolean Bool
|
||||||
|
| ConstNull
|
||||||
|
| ConstEnum Name
|
||||||
|
| ConstList [ConstValue]
|
||||||
|
| ConstObject [ObjectField ConstValue]
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | Key-value pair.
|
-- | Key-value pair.
|
||||||
--
|
--
|
||||||
-- A list of 'ObjectField's represents a GraphQL object type.
|
-- A list of 'ObjectField's represents a GraphQL object type.
|
||||||
data ObjectField = ObjectField Name Value deriving (Eq, Show)
|
data ObjectField a = ObjectField Name a
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Variables
|
-- ** Variables
|
||||||
|
|
||||||
-- | Variable definition.
|
-- | Variable definition.
|
||||||
data VariableDefinition = VariableDefinition Name Type (Maybe Value)
|
--
|
||||||
|
-- Each operation can include a list of variables:
|
||||||
|
--
|
||||||
|
-- @
|
||||||
|
-- query (protagonist: String = "Zarathustra") {
|
||||||
|
-- getAuthor(protagonist: $protagonist)
|
||||||
|
-- }
|
||||||
|
-- @
|
||||||
|
--
|
||||||
|
-- This query defines an optional variable @protagonist@ of type @String@,
|
||||||
|
-- its default value is "Zarathustra". If no default value is defined and no
|
||||||
|
-- value is provided, a variable can still be @null@ if its type is nullable.
|
||||||
|
--
|
||||||
|
-- Variables are usually passed along with the query, but not in the query
|
||||||
|
-- itself. They make queries reusable.
|
||||||
|
data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue)
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Type References
|
-- ** Type References
|
||||||
|
@ -445,7 +474,7 @@ instance Monoid ArgumentsDefinition where
|
||||||
--
|
--
|
||||||
-- The input type "Point2D" contains two value definitions: "x" and "y".
|
-- The input type "Point2D" contains two value definitions: "x" and "y".
|
||||||
data InputValueDefinition
|
data InputValueDefinition
|
||||||
= InputValueDefinition Description Name Type (Maybe Value) [Directive]
|
= InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- ** Unions
|
-- ** Unions
|
||||||
|
|
|
@ -24,7 +24,6 @@ import Data.Text.Lazy.Builder (Builder)
|
||||||
import qualified Data.Text.Lazy.Builder as Builder
|
import qualified Data.Text.Lazy.Builder as Builder
|
||||||
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
|
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
|
||||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||||
import qualified Language.GraphQL.AST as Full
|
|
||||||
import Language.GraphQL.AST.Document
|
import Language.GraphQL.AST.Document
|
||||||
|
|
||||||
-- | Instructs the encoder whether the GraphQL document should be minified or
|
-- | Instructs the encoder whether the GraphQL document should be minified or
|
||||||
|
@ -53,32 +52,32 @@ document formatter defs
|
||||||
executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
|
executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
|
||||||
executableDefinition _ acc = acc
|
executableDefinition _ acc = acc
|
||||||
|
|
||||||
-- | Converts a t'Full.ExecutableDefinition' into a string.
|
-- | Converts a t'ExecutableDefinition' into a string.
|
||||||
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
|
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
|
||||||
definition formatter x
|
definition formatter x
|
||||||
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
||||||
| Minified <- formatter = encodeDefinition x
|
| Minified <- formatter = encodeDefinition x
|
||||||
where
|
where
|
||||||
encodeDefinition (Full.DefinitionOperation operation)
|
encodeDefinition (DefinitionOperation operation)
|
||||||
= operationDefinition formatter operation
|
= operationDefinition formatter operation
|
||||||
encodeDefinition (Full.DefinitionFragment fragment)
|
encodeDefinition (DefinitionFragment fragment)
|
||||||
= fragmentDefinition formatter fragment
|
= fragmentDefinition formatter fragment
|
||||||
|
|
||||||
-- | Converts a 'Full.OperationDefinition into a string.
|
-- | Converts a 'OperationDefinition into a string.
|
||||||
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
|
operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
|
||||||
operationDefinition formatter (Full.SelectionSet sels)
|
operationDefinition formatter (SelectionSet sels)
|
||||||
= selectionSet formatter sels
|
= selectionSet formatter sels
|
||||||
operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
|
operationDefinition formatter (OperationDefinition Query name vars dirs sels)
|
||||||
= "query " <> node formatter name vars dirs sels
|
= "query " <> node formatter name vars dirs sels
|
||||||
operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
|
operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
|
||||||
= "mutation " <> node formatter name vars dirs sels
|
= "mutation " <> node formatter name vars dirs sels
|
||||||
|
|
||||||
-- | Converts a Full.Query or Full.Mutation into a string.
|
-- | Converts a Query or Mutation into a string.
|
||||||
node :: Formatter ->
|
node :: Formatter ->
|
||||||
Maybe Full.Name ->
|
Maybe Name ->
|
||||||
[Full.VariableDefinition] ->
|
[VariableDefinition] ->
|
||||||
[Full.Directive] ->
|
[Directive] ->
|
||||||
Full.SelectionSet ->
|
SelectionSet ->
|
||||||
Lazy.Text
|
Lazy.Text
|
||||||
node formatter name vars dirs sels
|
node formatter name vars dirs sels
|
||||||
= Lazy.Text.fromStrict (fold name)
|
= Lazy.Text.fromStrict (fold name)
|
||||||
|
@ -87,31 +86,31 @@ node formatter name vars dirs sels
|
||||||
<> eitherFormat formatter " " mempty
|
<> eitherFormat formatter " " mempty
|
||||||
<> selectionSet formatter sels
|
<> selectionSet formatter sels
|
||||||
|
|
||||||
variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
|
variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text
|
||||||
variableDefinitions formatter
|
variableDefinitions formatter
|
||||||
= parensCommas formatter $ variableDefinition formatter
|
= parensCommas formatter $ variableDefinition formatter
|
||||||
|
|
||||||
variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
|
variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text
|
||||||
variableDefinition formatter (Full.VariableDefinition var ty dv)
|
variableDefinition formatter (VariableDefinition var ty defaultValue')
|
||||||
= variable var
|
= variable var
|
||||||
<> eitherFormat formatter ": " ":"
|
<> eitherFormat formatter ": " ":"
|
||||||
<> type' ty
|
<> type' ty
|
||||||
<> maybe mempty (defaultValue formatter) dv
|
<> maybe mempty (defaultValue formatter) defaultValue'
|
||||||
|
|
||||||
defaultValue :: Formatter -> Full.Value -> Lazy.Text
|
defaultValue :: Formatter -> ConstValue -> Lazy.Text
|
||||||
defaultValue formatter val
|
defaultValue formatter val
|
||||||
= eitherFormat formatter " = " "="
|
= eitherFormat formatter " = " "="
|
||||||
<> value formatter val
|
<> value formatter (fromConstValue val)
|
||||||
|
|
||||||
variable :: Full.Name -> Lazy.Text
|
variable :: Name -> Lazy.Text
|
||||||
variable var = "$" <> Lazy.Text.fromStrict var
|
variable var = "$" <> Lazy.Text.fromStrict var
|
||||||
|
|
||||||
selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
|
selectionSet :: Formatter -> SelectionSet -> Lazy.Text
|
||||||
selectionSet formatter
|
selectionSet formatter
|
||||||
= bracesList formatter (selection formatter)
|
= bracesList formatter (selection formatter)
|
||||||
. NonEmpty.toList
|
. NonEmpty.toList
|
||||||
|
|
||||||
selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
|
selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text
|
||||||
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
||||||
|
|
||||||
indentSymbol :: Lazy.Text
|
indentSymbol :: Lazy.Text
|
||||||
|
@ -120,14 +119,14 @@ indentSymbol = " "
|
||||||
indent :: (Integral a) => a -> Lazy.Text
|
indent :: (Integral a) => a -> Lazy.Text
|
||||||
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
|
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
|
||||||
|
|
||||||
selection :: Formatter -> Full.Selection -> Lazy.Text
|
selection :: Formatter -> Selection -> Lazy.Text
|
||||||
selection formatter = Lazy.Text.append indent' . encodeSelection
|
selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||||
where
|
where
|
||||||
encodeSelection (Full.Field alias name args directives' selections) =
|
encodeSelection (Field alias name args directives' selections) =
|
||||||
field incrementIndent alias name args directives' selections
|
field incrementIndent alias name args directives' selections
|
||||||
encodeSelection (Full.InlineFragment typeCondition directives' selections) =
|
encodeSelection (InlineFragment typeCondition directives' selections) =
|
||||||
inlineFragment incrementIndent typeCondition directives' selections
|
inlineFragment incrementIndent typeCondition directives' selections
|
||||||
encodeSelection (Full.FragmentSpread name directives') =
|
encodeSelection (FragmentSpread name directives') =
|
||||||
fragmentSpread incrementIndent name directives'
|
fragmentSpread incrementIndent name directives'
|
||||||
incrementIndent
|
incrementIndent
|
||||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||||
|
@ -139,13 +138,13 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||||
colon :: Formatter -> Lazy.Text
|
colon :: Formatter -> Lazy.Text
|
||||||
colon formatter = eitherFormat formatter ": " ":"
|
colon formatter = eitherFormat formatter ": " ":"
|
||||||
|
|
||||||
-- | Converts Full.Field into a string
|
-- | Converts Field into a string
|
||||||
field :: Formatter ->
|
field :: Formatter ->
|
||||||
Maybe Full.Name ->
|
Maybe Name ->
|
||||||
Full.Name ->
|
Name ->
|
||||||
[Full.Argument] ->
|
[Argument] ->
|
||||||
[Full.Directive] ->
|
[Directive] ->
|
||||||
[Full.Selection] ->
|
[Selection] ->
|
||||||
Lazy.Text
|
Lazy.Text
|
||||||
field formatter alias name args dirs set
|
field formatter alias name args dirs set
|
||||||
= optempty prependAlias (fold alias)
|
= optempty prependAlias (fold alias)
|
||||||
|
@ -158,27 +157,27 @@ field formatter alias name args dirs set
|
||||||
selectionSetOpt' = (eitherFormat formatter " " "" <>)
|
selectionSetOpt' = (eitherFormat formatter " " "" <>)
|
||||||
. selectionSetOpt formatter
|
. selectionSetOpt formatter
|
||||||
|
|
||||||
arguments :: Formatter -> [Full.Argument] -> Lazy.Text
|
arguments :: Formatter -> [Argument] -> Lazy.Text
|
||||||
arguments formatter = parensCommas formatter $ argument formatter
|
arguments formatter = parensCommas formatter $ argument formatter
|
||||||
|
|
||||||
argument :: Formatter -> Full.Argument -> Lazy.Text
|
argument :: Formatter -> Argument -> Lazy.Text
|
||||||
argument formatter (Full.Argument name value')
|
argument formatter (Argument name value')
|
||||||
= Lazy.Text.fromStrict name
|
= Lazy.Text.fromStrict name
|
||||||
<> colon formatter
|
<> colon formatter
|
||||||
<> value formatter value'
|
<> value formatter value'
|
||||||
|
|
||||||
-- * Fragments
|
-- * Fragments
|
||||||
|
|
||||||
fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text
|
fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
|
||||||
fragmentSpread formatter name directives'
|
fragmentSpread formatter name directives'
|
||||||
= "..." <> Lazy.Text.fromStrict name
|
= "..." <> Lazy.Text.fromStrict name
|
||||||
<> optempty (directives formatter) directives'
|
<> optempty (directives formatter) directives'
|
||||||
|
|
||||||
inlineFragment ::
|
inlineFragment ::
|
||||||
Formatter ->
|
Formatter ->
|
||||||
Maybe Full.TypeCondition ->
|
Maybe TypeCondition ->
|
||||||
[Full.Directive] ->
|
[Directive] ->
|
||||||
Full.SelectionSet ->
|
SelectionSet ->
|
||||||
Lazy.Text
|
Lazy.Text
|
||||||
inlineFragment formatter tc dirs sels = "... on "
|
inlineFragment formatter tc dirs sels = "... on "
|
||||||
<> Lazy.Text.fromStrict (fold tc)
|
<> Lazy.Text.fromStrict (fold tc)
|
||||||
|
@ -186,8 +185,8 @@ inlineFragment formatter tc dirs sels = "... on "
|
||||||
<> eitherFormat formatter " " mempty
|
<> eitherFormat formatter " " mempty
|
||||||
<> selectionSet formatter sels
|
<> selectionSet formatter sels
|
||||||
|
|
||||||
fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
|
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
|
||||||
fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
|
fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
|
||||||
= "fragment " <> Lazy.Text.fromStrict name
|
= "fragment " <> Lazy.Text.fromStrict name
|
||||||
<> " on " <> Lazy.Text.fromStrict tc
|
<> " on " <> Lazy.Text.fromStrict tc
|
||||||
<> optempty (directives formatter) dirs
|
<> optempty (directives formatter) dirs
|
||||||
|
@ -196,26 +195,39 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
|
||||||
|
|
||||||
-- * Miscellaneous
|
-- * Miscellaneous
|
||||||
|
|
||||||
-- | Converts a 'Full.Directive' into a string.
|
-- | Converts a 'Directive' into a string.
|
||||||
directive :: Formatter -> Full.Directive -> Lazy.Text
|
directive :: Formatter -> Directive -> Lazy.Text
|
||||||
directive formatter (Full.Directive name args)
|
directive formatter (Directive name args)
|
||||||
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
|
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
|
||||||
|
|
||||||
directives :: Formatter -> [Full.Directive] -> Lazy.Text
|
directives :: Formatter -> [Directive] -> Lazy.Text
|
||||||
directives Minified = spaces (directive Minified)
|
directives Minified = spaces (directive Minified)
|
||||||
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
|
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
|
||||||
|
|
||||||
-- | Converts a 'Full.Value' into a string.
|
-- | Converts a 'Value' into a string.
|
||||||
value :: Formatter -> Full.Value -> Lazy.Text
|
value :: Formatter -> Value -> Lazy.Text
|
||||||
value _ (Full.Variable x) = variable x
|
value _ (Variable x) = variable x
|
||||||
value _ (Full.Int x) = Builder.toLazyText $ decimal x
|
value _ (Int x) = Builder.toLazyText $ decimal x
|
||||||
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
|
value _ (Float x) = Builder.toLazyText $ realFloat x
|
||||||
value _ (Full.Boolean x) = booleanValue x
|
value _ (Boolean x) = booleanValue x
|
||||||
value _ Full.Null = "null"
|
value _ Null = "null"
|
||||||
value formatter (Full.String string) = stringValue formatter string
|
value formatter (String string) = stringValue formatter string
|
||||||
value _ (Full.Enum x) = Lazy.Text.fromStrict x
|
value _ (Enum x) = Lazy.Text.fromStrict x
|
||||||
value formatter (Full.List x) = listValue formatter x
|
value formatter (List x) = listValue formatter x
|
||||||
value formatter (Full.Object x) = objectValue formatter x
|
value formatter (Object x) = objectValue formatter x
|
||||||
|
|
||||||
|
fromConstValue :: ConstValue -> Value
|
||||||
|
fromConstValue (ConstInt x) = Int x
|
||||||
|
fromConstValue (ConstFloat x) = Float x
|
||||||
|
fromConstValue (ConstBoolean x) = Boolean x
|
||||||
|
fromConstValue ConstNull = Null
|
||||||
|
fromConstValue (ConstString string) = String string
|
||||||
|
fromConstValue (ConstEnum x) = Enum x
|
||||||
|
fromConstValue (ConstList x) = List $ fromConstValue <$> x
|
||||||
|
fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x
|
||||||
|
where
|
||||||
|
fromConstObjectField (ObjectField key value') =
|
||||||
|
ObjectField key $ fromConstValue value'
|
||||||
|
|
||||||
booleanValue :: Bool -> Lazy.Text
|
booleanValue :: Bool -> Lazy.Text
|
||||||
booleanValue True = "true"
|
booleanValue True = "true"
|
||||||
|
@ -271,10 +283,10 @@ escape char'
|
||||||
where
|
where
|
||||||
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
|
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
|
||||||
|
|
||||||
listValue :: Formatter -> [Full.Value] -> Lazy.Text
|
listValue :: Formatter -> [Value] -> Lazy.Text
|
||||||
listValue formatter = bracketsCommas formatter $ value formatter
|
listValue formatter = bracketsCommas formatter $ value formatter
|
||||||
|
|
||||||
objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text
|
objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text
|
||||||
objectValue formatter = intercalate $ objectField formatter
|
objectValue formatter = intercalate $ objectField formatter
|
||||||
where
|
where
|
||||||
intercalate f
|
intercalate f
|
||||||
|
@ -282,22 +294,22 @@ objectValue formatter = intercalate $ objectField formatter
|
||||||
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
|
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
|
||||||
. fmap f
|
. fmap f
|
||||||
|
|
||||||
objectField :: Formatter -> Full.ObjectField -> Lazy.Text
|
objectField :: Formatter -> ObjectField Value -> Lazy.Text
|
||||||
objectField formatter (Full.ObjectField name value') =
|
objectField formatter (ObjectField name value') =
|
||||||
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
|
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
|
||||||
|
|
||||||
-- | Converts a 'Full.Type' a type into a string.
|
-- | Converts a 'Type' a type into a string.
|
||||||
type' :: Full.Type -> Lazy.Text
|
type' :: Type -> Lazy.Text
|
||||||
type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
|
type' (TypeNamed x) = Lazy.Text.fromStrict x
|
||||||
type' (Full.TypeList x) = listType x
|
type' (TypeList x) = listType x
|
||||||
type' (Full.TypeNonNull x) = nonNullType x
|
type' (TypeNonNull x) = nonNullType x
|
||||||
|
|
||||||
listType :: Full.Type -> Lazy.Text
|
listType :: Type -> Lazy.Text
|
||||||
listType x = brackets (type' x)
|
listType x = brackets (type' x)
|
||||||
|
|
||||||
nonNullType :: Full.NonNullType -> Lazy.Text
|
nonNullType :: NonNullType -> Lazy.Text
|
||||||
nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||||
nonNullType (Full.NonNullTypeList x) = listType x <> "!"
|
nonNullType (NonNullTypeList x) = listType x <> "!"
|
||||||
|
|
||||||
-- * Internal
|
-- * Internal
|
||||||
|
|
||||||
|
|
|
@ -403,32 +403,38 @@ typeCondition = symbol "on" *> name
|
||||||
|
|
||||||
value :: Parser Value
|
value :: Parser Value
|
||||||
value = Variable <$> variable
|
value = Variable <$> variable
|
||||||
<|> Float <$> try float
|
<|> Float <$> try float
|
||||||
<|> Int <$> integer
|
<|> Int <$> integer
|
||||||
<|> Boolean <$> booleanValue
|
<|> Boolean <$> booleanValue
|
||||||
<|> Null <$ symbol "null"
|
<|> Null <$ symbol "null"
|
||||||
<|> String <$> blockString
|
<|> String <$> blockString
|
||||||
<|> String <$> string
|
<|> String <$> string
|
||||||
<|> Enum <$> try enumValue
|
<|> Enum <$> try enumValue
|
||||||
<|> List <$> listValue
|
<|> List <$> brackets (some value)
|
||||||
<|> Object <$> objectValue
|
<|> Object <$> braces (some $ objectField value)
|
||||||
<?> "value error!"
|
<?> "value error!"
|
||||||
where
|
|
||||||
booleanValue :: Parser Bool
|
|
||||||
booleanValue = True <$ symbol "true"
|
|
||||||
<|> False <$ symbol "false"
|
|
||||||
|
|
||||||
listValue :: Parser [Value]
|
constValue :: Parser ConstValue
|
||||||
listValue = brackets $ some value
|
constValue = ConstFloat <$> try float
|
||||||
|
<|> ConstInt <$> integer
|
||||||
|
<|> ConstBoolean <$> booleanValue
|
||||||
|
<|> ConstNull <$ symbol "null"
|
||||||
|
<|> ConstString <$> blockString
|
||||||
|
<|> ConstString <$> string
|
||||||
|
<|> ConstEnum <$> try enumValue
|
||||||
|
<|> ConstList <$> brackets (some constValue)
|
||||||
|
<|> ConstObject <$> braces (some $ objectField constValue)
|
||||||
|
<?> "value error!"
|
||||||
|
|
||||||
objectValue :: Parser [ObjectField]
|
booleanValue :: Parser Bool
|
||||||
objectValue = braces $ some objectField
|
booleanValue = True <$ symbol "true"
|
||||||
|
<|> False <$ symbol "false"
|
||||||
|
|
||||||
enumValue :: Parser Name
|
enumValue :: Parser Name
|
||||||
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
|
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
|
||||||
|
|
||||||
objectField :: Parser ObjectField
|
objectField :: Parser a -> Parser (ObjectField a)
|
||||||
objectField = ObjectField <$> name <* colon <*> value
|
objectField valueParser = ObjectField <$> name <* colon <*> valueParser
|
||||||
|
|
||||||
-- * Variables
|
-- * Variables
|
||||||
|
|
||||||
|
@ -446,8 +452,8 @@ variableDefinition = VariableDefinition
|
||||||
variable :: Parser Name
|
variable :: Parser Name
|
||||||
variable = dollar *> name
|
variable = dollar *> name
|
||||||
|
|
||||||
defaultValue :: Parser (Maybe Value)
|
defaultValue :: Parser (Maybe ConstValue)
|
||||||
defaultValue = optional (equals *> value) <?> "DefaultValue"
|
defaultValue = optional (equals *> constValue) <?> "DefaultValue"
|
||||||
|
|
||||||
-- * Input Types
|
-- * Input Types
|
||||||
|
|
||||||
|
|
|
@ -5,21 +5,20 @@
|
||||||
module Language.GraphQL.Error
|
module Language.GraphQL.Error
|
||||||
( parseError
|
( parseError
|
||||||
, CollectErrsT
|
, CollectErrsT
|
||||||
|
, Resolution(..)
|
||||||
, addErr
|
, addErr
|
||||||
, addErrMsg
|
, addErrMsg
|
||||||
, runCollectErrs
|
, runCollectErrs
|
||||||
, runAppendErrs
|
|
||||||
, singleError
|
, singleError
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Trans.State (StateT, modify, runStateT)
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Void (Void)
|
import Data.Void (Void)
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Language.GraphQL.AST.Document (Name)
|
||||||
import Control.Monad.Trans.State ( StateT
|
import Language.GraphQL.Type.Schema
|
||||||
, modify
|
|
||||||
, runStateT
|
|
||||||
)
|
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
( ParseErrorBundle(..)
|
( ParseErrorBundle(..)
|
||||||
, PosState(..)
|
, PosState(..)
|
||||||
|
@ -30,6 +29,12 @@ import Text.Megaparsec
|
||||||
, unPos
|
, unPos
|
||||||
)
|
)
|
||||||
|
|
||||||
|
-- | Executor context.
|
||||||
|
data Resolution m = Resolution
|
||||||
|
{ errors :: [Aeson.Value]
|
||||||
|
, types :: HashMap Name (Type m)
|
||||||
|
}
|
||||||
|
|
||||||
-- | Wraps a parse error into a list of errors.
|
-- | Wraps a parse error into a list of errors.
|
||||||
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
|
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
|
||||||
parseError ParseErrorBundle{..} =
|
parseError ParseErrorBundle{..} =
|
||||||
|
@ -46,11 +51,13 @@ parseError ParseErrorBundle{..} =
|
||||||
in (errorObject x sourcePosition : result, newState)
|
in (errorObject x sourcePosition : result, newState)
|
||||||
|
|
||||||
-- | A wrapper to pass error messages around.
|
-- | A wrapper to pass error messages around.
|
||||||
type CollectErrsT m = StateT [Aeson.Value] m
|
type CollectErrsT m = StateT (Resolution m) m
|
||||||
|
|
||||||
-- | Adds an error to the list of errors.
|
-- | Adds an error to the list of errors.
|
||||||
addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
|
addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
|
||||||
addErr v = modify (v :)
|
addErr v = modify appender
|
||||||
|
where
|
||||||
|
appender resolution@Resolution{..} = resolution{ errors = v : errors }
|
||||||
|
|
||||||
makeErrorMessage :: Text -> Aeson.Value
|
makeErrorMessage :: Text -> Aeson.Value
|
||||||
makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]
|
makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]
|
||||||
|
@ -66,23 +73,17 @@ singleError message = Aeson.object
|
||||||
addErrMsg :: Monad m => Text -> CollectErrsT m ()
|
addErrMsg :: Monad m => Text -> CollectErrsT m ()
|
||||||
addErrMsg = addErr . makeErrorMessage
|
addErrMsg = addErr . makeErrorMessage
|
||||||
|
|
||||||
-- | Appends the given list of errors to the current list of errors.
|
|
||||||
appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m ()
|
|
||||||
appendErrs errs = modify (errs ++)
|
|
||||||
|
|
||||||
-- | Runs the given query computation, but collects the errors into an error
|
-- | Runs the given query computation, but collects the errors into an error
|
||||||
-- list, which is then sent back with the data.
|
-- list, which is then sent back with the data.
|
||||||
runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value
|
runCollectErrs :: Monad m
|
||||||
runCollectErrs res = do
|
=> HashMap Name (Type m)
|
||||||
(dat, errs) <- runStateT res []
|
-> CollectErrsT m Aeson.Value
|
||||||
if null errs
|
-> m Aeson.Value
|
||||||
|
runCollectErrs types' res = do
|
||||||
|
(dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' }
|
||||||
|
if null errors
|
||||||
then return $ Aeson.object [("data", dat)]
|
then return $ Aeson.object [("data", dat)]
|
||||||
else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]
|
else return $ Aeson.object
|
||||||
|
[ ("data", dat)
|
||||||
-- | Runs the given computation, collecting the errors and appending them
|
, ("errors", Aeson.toJSON $ reverse errors)
|
||||||
-- to the previous list of errors.
|
]
|
||||||
runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a
|
|
||||||
runAppendErrs f = do
|
|
||||||
(v, errs) <- lift $ runStateT f []
|
|
||||||
appendErrs errs
|
|
||||||
return v
|
|
||||||
|
|
|
@ -1,5 +1,3 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
-- | This module provides functions to execute a @GraphQL@ request.
|
-- | This module provides functions to execute a @GraphQL@ request.
|
||||||
module Language.GraphQL.Execute
|
module Language.GraphQL.Execute
|
||||||
( execute
|
( execute
|
||||||
|
@ -7,33 +5,30 @@ module Language.GraphQL.Execute
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
|
||||||
import qualified Data.List.NonEmpty as NonEmpty
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Data.Sequence (Seq(..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as Text
|
import Language.GraphQL.AST.Document (Document, Name)
|
||||||
import Language.GraphQL.AST.Document
|
import Language.GraphQL.Execute.Coerce
|
||||||
import qualified Language.GraphQL.AST.Core as AST.Core
|
import Language.GraphQL.Execute.Execution
|
||||||
import qualified Language.GraphQL.Execute.Transform as Transform
|
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||||
import Language.GraphQL.Error
|
import Language.GraphQL.Error
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
import qualified Language.GraphQL.Type.Definition as Definition
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
import Language.GraphQL.Type.Schema
|
||||||
|
|
||||||
-- | The substitution is applied to the document, and the resolvers are applied
|
-- | The substitution is applied to the document, and the resolvers are applied
|
||||||
-- to the resulting fields.
|
-- to the resulting fields.
|
||||||
--
|
--
|
||||||
-- Returns the result of the query against the schema wrapped in a /data/
|
-- Returns the result of the query against the schema wrapped in a /data/
|
||||||
-- field, or errors wrapped in an /errors/ field.
|
-- field, or errors wrapped in an /errors/ field.
|
||||||
execute :: Monad m
|
execute :: (Monad m, VariableValue a)
|
||||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
=> Schema m -- ^ Resolvers.
|
||||||
-> Schema.Subs -- ^ Variable substitution function.
|
-> HashMap.HashMap Name a -- ^ Variable substitution function.
|
||||||
-> Document -- @GraphQL@ document.
|
-> Document -- @GraphQL@ document.
|
||||||
-> m Aeson.Value
|
-> m Aeson.Value
|
||||||
execute schema subs doc =
|
execute schema = executeRequest schema Nothing
|
||||||
maybe transformError (document schema Nothing)
|
|
||||||
$ Transform.document subs doc
|
|
||||||
where
|
|
||||||
transformError = return $ singleError "Schema transformation error."
|
|
||||||
|
|
||||||
-- | The substitution is applied to the document, and the resolvers are applied
|
-- | The substitution is applied to the document, and the resolvers are applied
|
||||||
-- to the resulting fields. The operation name can be used if the document
|
-- to the resulting fields. The operation name can be used if the document
|
||||||
|
@ -41,46 +36,36 @@ execute schema subs doc =
|
||||||
--
|
--
|
||||||
-- Returns the result of the query against the schema wrapped in a /data/
|
-- Returns the result of the query against the schema wrapped in a /data/
|
||||||
-- field, or errors wrapped in an /errors/ field.
|
-- field, or errors wrapped in an /errors/ field.
|
||||||
executeWithName :: Monad m
|
executeWithName :: (Monad m, VariableValue a)
|
||||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
|
=> Schema m -- ^ Resolvers
|
||||||
-> Text -- ^ Operation name.
|
-> Text -- ^ Operation name.
|
||||||
-> Schema.Subs -- ^ Variable substitution function.
|
-> HashMap.HashMap Name a -- ^ Variable substitution function.
|
||||||
-> Document -- ^ @GraphQL@ Document.
|
-> Document -- ^ @GraphQL@ Document.
|
||||||
-> m Aeson.Value
|
-> m Aeson.Value
|
||||||
executeWithName schema name subs doc =
|
executeWithName schema operationName =
|
||||||
maybe transformError (document schema $ Just name)
|
executeRequest schema (Just operationName)
|
||||||
$ Transform.document subs doc
|
|
||||||
where
|
|
||||||
transformError = return $ singleError "Schema transformation error."
|
|
||||||
|
|
||||||
document :: Monad m
|
executeRequest :: (Monad m, VariableValue a)
|
||||||
=> HashMap Text (NonEmpty (Schema.Resolver m))
|
=> Schema m
|
||||||
-> Maybe Text
|
-> Maybe Text
|
||||||
-> AST.Core.Document
|
-> HashMap.HashMap Name a
|
||||||
|
-> Document
|
||||||
-> m Aeson.Value
|
-> m Aeson.Value
|
||||||
document schema Nothing (op :| []) = operation schema op
|
executeRequest schema operationName subs document =
|
||||||
document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of
|
case Transform.document schema operationName subs document of
|
||||||
[] -> return $ singleError
|
Left queryError -> pure $ singleError $ Transform.queryError queryError
|
||||||
$ Text.unwords ["Operation", name, "couldn't be found in the document."]
|
Right (Transform.Document types' rootObjectType operation)
|
||||||
(op:_) -> operation schema op
|
| (Transform.Query _ fields) <- operation ->
|
||||||
where
|
executeOperation types' rootObjectType fields
|
||||||
matchingName (AST.Core.Query (Just name') _) = name == name'
|
| (Transform.Mutation _ fields) <- operation ->
|
||||||
matchingName (AST.Core.Mutation (Just name') _) = name == name'
|
executeOperation types' rootObjectType fields
|
||||||
matchingName _ = False
|
|
||||||
document _ _ _ = return $ singleError "Missing operation name."
|
|
||||||
|
|
||||||
operation :: Monad m
|
-- This is actually executeMutation, but we don't distinguish between queries
|
||||||
=> HashMap Text (NonEmpty (Schema.Resolver m))
|
-- and mutations yet.
|
||||||
-> AST.Core.Operation
|
executeOperation :: Monad m
|
||||||
|
=> HashMap Name (Type m)
|
||||||
|
-> Out.ObjectType m
|
||||||
|
-> Seq (Transform.Selection m)
|
||||||
-> m Aeson.Value
|
-> m Aeson.Value
|
||||||
operation schema = schemaOperation
|
executeOperation types' objectType fields =
|
||||||
where
|
runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields
|
||||||
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"
|
|
||||||
|
|
|
@ -0,0 +1,230 @@
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
-- | Types and functions used for input and result coercion.
|
||||||
|
module Language.GraphQL.Execute.Coerce
|
||||||
|
( Output(..)
|
||||||
|
, Serialize(..)
|
||||||
|
, VariableValue(..)
|
||||||
|
, coerceInputLiteral
|
||||||
|
, matchFieldValues
|
||||||
|
) where
|
||||||
|
|
||||||
|
import qualified Data.Aeson as Aeson
|
||||||
|
import Data.Int (Int32)
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Data.Map.Strict (Map)
|
||||||
|
import Data.String (IsString(..))
|
||||||
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text.Lazy as Text.Lazy
|
||||||
|
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||||
|
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
|
||||||
|
import Data.Scientific (toBoundedInteger, toRealFloat)
|
||||||
|
import Language.GraphQL.AST (Name)
|
||||||
|
import qualified Language.GraphQL.Type as Type
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
|
||||||
|
-- | Since variables are passed separately from the query, in an independent
|
||||||
|
-- format, they should be first coerced to the internal representation used by
|
||||||
|
-- this implementation.
|
||||||
|
class VariableValue a where
|
||||||
|
-- | Only a basic, format-specific, coercion must be done here. Type
|
||||||
|
-- correctness or nullability shouldn't be validated here, they will be
|
||||||
|
-- validated later. The type information is provided only as a hint.
|
||||||
|
--
|
||||||
|
-- For example @GraphQL@ prohibits the coercion from a 't:Float' to an
|
||||||
|
-- 't:Int', but @JSON@ doesn't have integers, so whole numbers should be
|
||||||
|
-- coerced to 't:Int` when receiving variables as a JSON object. The same
|
||||||
|
-- holds for 't:Enum'. There are formats that support enumerations, @JSON@
|
||||||
|
-- doesn't, so the type information is given and 'coerceVariableValue' can
|
||||||
|
-- check that an 't:Enum' is expected and treat the given value
|
||||||
|
-- appropriately. Even checking whether this value is a proper member of the
|
||||||
|
-- corresponding 't:Enum' type isn't required here, since this can be
|
||||||
|
-- checked independently.
|
||||||
|
--
|
||||||
|
-- Another example is an @ID@. @GraphQL@ explicitly allows to coerce
|
||||||
|
-- integers and strings to @ID@s, so if an @ID@ is received as an integer,
|
||||||
|
-- it can be left as is and will be coerced later.
|
||||||
|
--
|
||||||
|
-- If a value cannot be coerced without losing information, 'Nothing' should
|
||||||
|
-- be returned, the coercion will fail then and the query won't be executed.
|
||||||
|
coerceVariableValue
|
||||||
|
:: In.Type -- ^ Expected type (variable type given in the query).
|
||||||
|
-> a -- ^ Variable value being coerced.
|
||||||
|
-> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.
|
||||||
|
|
||||||
|
instance VariableValue Aeson.Value where
|
||||||
|
coerceVariableValue _ Aeson.Null = Just Type.Null
|
||||||
|
coerceVariableValue (In.ScalarBaseType scalarType) value
|
||||||
|
| (Aeson.String stringValue) <- value = Just $ Type.String stringValue
|
||||||
|
| (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
|
||||||
|
| (Aeson.Number numberValue) <- value
|
||||||
|
, (Type.ScalarType "Float" _) <- scalarType =
|
||||||
|
Just $ Type.Float $ toRealFloat numberValue
|
||||||
|
| (Aeson.Number numberValue) <- value = -- ID or Int
|
||||||
|
Type.Int <$> toBoundedInteger numberValue
|
||||||
|
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
|
||||||
|
Just $ Type.Enum stringValue
|
||||||
|
coerceVariableValue (In.InputObjectBaseType objectType) value
|
||||||
|
| (Aeson.Object objectValue) <- value = do
|
||||||
|
let (In.InputObjectType _ _ inputFields) = objectType
|
||||||
|
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
|
||||||
|
if HashMap.null newObjectValue
|
||||||
|
then Just $ Type.Object resultMap
|
||||||
|
else Nothing
|
||||||
|
where
|
||||||
|
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
|
||||||
|
$ Just (objectValue, HashMap.empty)
|
||||||
|
matchFieldValues' _ _ Nothing = Nothing
|
||||||
|
matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
|
||||||
|
let (In.InputField _ fieldType _) = inputField
|
||||||
|
insert = flip (HashMap.insert fieldName) resultMap
|
||||||
|
newObjectValue = HashMap.delete fieldName objectValue
|
||||||
|
in case HashMap.lookup fieldName objectValue of
|
||||||
|
Just variableValue -> do
|
||||||
|
coerced <- coerceVariableValue fieldType variableValue
|
||||||
|
pure (newObjectValue, insert coerced)
|
||||||
|
Nothing -> Just (objectValue, resultMap)
|
||||||
|
coerceVariableValue (In.ListBaseType listType) value
|
||||||
|
| (Aeson.Array arrayValue) <- value =
|
||||||
|
Type.List <$> foldr foldVector (Just []) arrayValue
|
||||||
|
| otherwise = coerceVariableValue listType value
|
||||||
|
where
|
||||||
|
foldVector _ Nothing = Nothing
|
||||||
|
foldVector variableValue (Just list) = do
|
||||||
|
coerced <- coerceVariableValue listType variableValue
|
||||||
|
pure $ coerced : list
|
||||||
|
coerceVariableValue _ _ = Nothing
|
||||||
|
|
||||||
|
-- | Looks up a value by name in the given map, coerces it and inserts into the
|
||||||
|
-- result map. If the coercion fails, returns 'Nothing'. If the value isn't
|
||||||
|
-- given, but a default value is known, inserts the default value into the
|
||||||
|
-- result map. Otherwise it fails with 'Nothing' if the Input Type is a
|
||||||
|
-- Non-Nullable type, or returns the unchanged, original map.
|
||||||
|
matchFieldValues :: forall a
|
||||||
|
. (In.Type -> a -> Maybe Type.Value)
|
||||||
|
-> HashMap Name a
|
||||||
|
-> Name
|
||||||
|
-> In.Type
|
||||||
|
-> Maybe Type.Value
|
||||||
|
-> Maybe (HashMap Name Type.Value)
|
||||||
|
-> Maybe (HashMap Name Type.Value)
|
||||||
|
matchFieldValues coerce values' fieldName type' defaultValue resultMap =
|
||||||
|
case HashMap.lookup fieldName values' of
|
||||||
|
Just variableValue -> coerceRuntimeValue $ coerce type' variableValue
|
||||||
|
Nothing
|
||||||
|
| Just value <- defaultValue ->
|
||||||
|
HashMap.insert fieldName value <$> resultMap
|
||||||
|
| Nothing <- defaultValue
|
||||||
|
, In.isNonNullType type' -> Nothing
|
||||||
|
| otherwise -> resultMap
|
||||||
|
where
|
||||||
|
coerceRuntimeValue (Just Type.Null)
|
||||||
|
| In.isNonNullType type' = Nothing
|
||||||
|
coerceRuntimeValue coercedValue =
|
||||||
|
HashMap.insert fieldName <$> coercedValue <*> resultMap
|
||||||
|
|
||||||
|
-- | Coerces operation arguments according to the input coercion rules for the
|
||||||
|
-- corresponding types.
|
||||||
|
coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value
|
||||||
|
coerceInputLiteral (In.isNonNullType -> False) Type.Null = Just Type.Null
|
||||||
|
coerceInputLiteral (In.ScalarBaseType type') value
|
||||||
|
| (Type.String stringValue) <- value
|
||||||
|
, (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue
|
||||||
|
| (Type.Boolean booleanValue) <- value
|
||||||
|
, (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue
|
||||||
|
| (Type.Int intValue) <- value
|
||||||
|
, (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue
|
||||||
|
| (Type.Float floatValue) <- value
|
||||||
|
, (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue
|
||||||
|
| (Type.Int intValue) <- value
|
||||||
|
, (Type.ScalarType "Float" _) <- type' =
|
||||||
|
Just $ Type.Float $ fromIntegral intValue
|
||||||
|
| (Type.String stringValue) <- value
|
||||||
|
, (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue
|
||||||
|
| (Type.Int intValue) <- value
|
||||||
|
, (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue
|
||||||
|
where
|
||||||
|
decimal = Type.String
|
||||||
|
. Text.Lazy.toStrict
|
||||||
|
. Text.Builder.toLazyText
|
||||||
|
. Text.Builder.decimal
|
||||||
|
coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
|
||||||
|
| member enumValue type' = Just $ Type.Enum enumValue
|
||||||
|
where
|
||||||
|
member value (Type.EnumType _ _ members) = HashMap.member value members
|
||||||
|
coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) =
|
||||||
|
let (In.InputObjectType _ _ inputFields) = type'
|
||||||
|
in Type.Object
|
||||||
|
<$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
|
||||||
|
where
|
||||||
|
matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) =
|
||||||
|
matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue
|
||||||
|
coerceInputLiteral (In.ListBaseType listType) (Type.List list) =
|
||||||
|
Type.List <$> traverse (coerceInputLiteral listType) list
|
||||||
|
coerceInputLiteral (In.ListBaseType listType) singleton =
|
||||||
|
wrapSingleton listType singleton
|
||||||
|
where
|
||||||
|
wrapSingleton (In.ListBaseType listType') singleton' =
|
||||||
|
Type.List <$> sequence [wrapSingleton listType' singleton']
|
||||||
|
wrapSingleton listType' singleton' =
|
||||||
|
Type.List <$> sequence [coerceInputLiteral listType' singleton']
|
||||||
|
coerceInputLiteral _ _ = Nothing
|
||||||
|
|
||||||
|
-- | 'Serialize' describes how a @GraphQL@ value should be serialized.
|
||||||
|
class Serialize a where
|
||||||
|
-- | Serializes a @GraphQL@ value according to the given serialization
|
||||||
|
-- format.
|
||||||
|
--
|
||||||
|
-- Type infomration is given as a hint, e.g. if you need to know what type
|
||||||
|
-- is being serialized to serialize it properly. Don't do any validation for
|
||||||
|
-- @GraphQL@ built-in types here.
|
||||||
|
--
|
||||||
|
-- If the value cannot be serialized without losing information, return
|
||||||
|
-- 'Nothing' — it will cause a field error.
|
||||||
|
serialize :: forall m
|
||||||
|
. Out.Type m -- ^ Expected output type.
|
||||||
|
-> Output a -- ^ The value to be serialized.
|
||||||
|
-> Maybe a -- ^ Serialized value on success or 'Nothing'.
|
||||||
|
-- | __null__ representation in the given serialization format.
|
||||||
|
null :: a
|
||||||
|
|
||||||
|
-- | Intermediate type used to serialize a @GraphQL@ value.
|
||||||
|
--
|
||||||
|
-- The serialization is done during the execution, and 'Output' contains
|
||||||
|
-- already serialized data (in 'List' and 'Object') as well as the new layer
|
||||||
|
-- that has to be serialized in the current step. So 'Output' is parameterized
|
||||||
|
-- by the serialization format.
|
||||||
|
data Output a
|
||||||
|
= Int Int32
|
||||||
|
| Float Double
|
||||||
|
| String Text
|
||||||
|
| Boolean Bool
|
||||||
|
| Enum Name
|
||||||
|
| List [a]
|
||||||
|
| Object (Map Name a)
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance forall a. IsString (Output a) where
|
||||||
|
fromString = String . fromString
|
||||||
|
|
||||||
|
instance Serialize Aeson.Value where
|
||||||
|
serialize (Out.ScalarBaseType scalarType) value
|
||||||
|
| Type.ScalarType "Int" _ <- scalarType
|
||||||
|
, Int int <- value = Just $ Aeson.toJSON int
|
||||||
|
| Type.ScalarType "Float" _ <- scalarType
|
||||||
|
, Float float <- value = Just $ Aeson.toJSON float
|
||||||
|
| Type.ScalarType "String" _ <- scalarType
|
||||||
|
, String string <- value = Just $ Aeson.String string
|
||||||
|
| Type.ScalarType "ID" _ <- scalarType
|
||||||
|
, String string <- value = Just $ Aeson.String string
|
||||||
|
| Type.ScalarType "Boolean" _ <- scalarType
|
||||||
|
, Boolean boolean <- value = Just $ Aeson.Bool boolean
|
||||||
|
serialize _ (Enum enum) = Just $ Aeson.String enum
|
||||||
|
serialize _ (List list) = Just $ Aeson.toJSON list
|
||||||
|
serialize _ (Object object) = Just $ Aeson.toJSON object
|
||||||
|
serialize _ _ = Nothing
|
||||||
|
null = Aeson.Null
|
|
@ -0,0 +1,229 @@
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
module Language.GraphQL.Execute.Execution
|
||||||
|
( executeSelectionSet
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Class (lift)
|
||||||
|
import Control.Monad.Trans.Except (runExceptT)
|
||||||
|
import Control.Monad.Trans.Reader (runReaderT)
|
||||||
|
import Control.Monad.Trans.State (gets)
|
||||||
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
|
import Data.Map.Strict (Map)
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
|
import Data.Sequence (Seq(..))
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Language.GraphQL.AST (Name)
|
||||||
|
import Language.GraphQL.AST.Core
|
||||||
|
import Language.GraphQL.Error
|
||||||
|
import Language.GraphQL.Execute.Coerce
|
||||||
|
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||||
|
import Language.GraphQL.Trans
|
||||||
|
import qualified Language.GraphQL.Type as Type
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
import Language.GraphQL.Type.Schema
|
||||||
|
import Prelude hiding (null)
|
||||||
|
|
||||||
|
resolveFieldValue :: Monad m
|
||||||
|
=> Type.Value
|
||||||
|
-> Type.Subs
|
||||||
|
-> ActionT m a
|
||||||
|
-> m (Either Text a)
|
||||||
|
resolveFieldValue result args =
|
||||||
|
flip runReaderT (Context {arguments = Arguments args, values = result})
|
||||||
|
. runExceptT
|
||||||
|
. runActionT
|
||||||
|
|
||||||
|
collectFields :: Monad m
|
||||||
|
=> Out.ObjectType m
|
||||||
|
-> Seq (Transform.Selection m)
|
||||||
|
-> Map Name (NonEmpty (Transform.Field m))
|
||||||
|
collectFields objectType = foldl forEach Map.empty
|
||||||
|
where
|
||||||
|
forEach groupedFields (Transform.SelectionField field) =
|
||||||
|
let responseKey = aliasOrName field
|
||||||
|
in Map.insertWith (<>) responseKey (field :| []) groupedFields
|
||||||
|
forEach groupedFields (Transform.SelectionFragment selectionFragment)
|
||||||
|
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
|
||||||
|
, doesFragmentTypeApply fragmentType objectType =
|
||||||
|
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
|
||||||
|
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
|
||||||
|
| otherwise = groupedFields
|
||||||
|
|
||||||
|
aliasOrName :: forall m. Transform.Field m -> Name
|
||||||
|
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
|
||||||
|
|
||||||
|
resolveAbstractType :: Monad m
|
||||||
|
=> AbstractType m
|
||||||
|
-> Type.Subs
|
||||||
|
-> CollectErrsT m (Maybe (Out.ObjectType m))
|
||||||
|
resolveAbstractType abstractType values'
|
||||||
|
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
|
||||||
|
types' <- gets types
|
||||||
|
case HashMap.lookup typeName types' of
|
||||||
|
Just (ObjectType objectType) ->
|
||||||
|
if instanceOf objectType abstractType
|
||||||
|
then pure $ Just objectType
|
||||||
|
else pure Nothing
|
||||||
|
_ -> pure Nothing
|
||||||
|
| otherwise = pure Nothing
|
||||||
|
|
||||||
|
doesFragmentTypeApply :: forall m
|
||||||
|
. CompositeType m
|
||||||
|
-> Out.ObjectType m
|
||||||
|
-> Bool
|
||||||
|
doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
|
||||||
|
fragmentType == objectType
|
||||||
|
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
|
||||||
|
instanceOf objectType $ AbstractInterfaceType fragmentType
|
||||||
|
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
|
||||||
|
instanceOf objectType $ AbstractUnionType fragmentType
|
||||||
|
|
||||||
|
instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
|
||||||
|
instanceOf objectType (AbstractInterfaceType interfaceType) =
|
||||||
|
let Out.ObjectType _ _ interfaces _ = objectType
|
||||||
|
in foldr go False interfaces
|
||||||
|
where
|
||||||
|
go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc =
|
||||||
|
acc || foldr go (interfaceType == objectInterfaceType) interfaces
|
||||||
|
instanceOf objectType (AbstractUnionType unionType) =
|
||||||
|
let Out.UnionType _ _ members = unionType
|
||||||
|
in foldr go False members
|
||||||
|
where
|
||||||
|
go unionMemberType acc = acc || objectType == unionMemberType
|
||||||
|
|
||||||
|
executeField :: (Monad m, Serialize a)
|
||||||
|
=> Out.Resolver m
|
||||||
|
-> Type.Value
|
||||||
|
-> NonEmpty (Transform.Field m)
|
||||||
|
-> CollectErrsT m a
|
||||||
|
executeField (Out.Resolver fieldDefinition resolver) prev fields = do
|
||||||
|
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
|
||||||
|
let (Transform.Field _ _ arguments' _ :| []) = fields
|
||||||
|
case coerceArgumentValues argumentDefinitions arguments' of
|
||||||
|
Nothing -> errmsg "Argument coercing failed."
|
||||||
|
Just argumentValues -> do
|
||||||
|
answer <- lift $ resolveFieldValue prev argumentValues resolver
|
||||||
|
case answer of
|
||||||
|
Right result -> completeValue fieldType fields result
|
||||||
|
Left errorMessage -> errmsg errorMessage
|
||||||
|
|
||||||
|
completeValue :: (Monad m, Serialize a)
|
||||||
|
=> Out.Type m
|
||||||
|
-> NonEmpty (Transform.Field m)
|
||||||
|
-> Type.Value
|
||||||
|
-> CollectErrsT m a
|
||||||
|
completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
|
||||||
|
completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
|
||||||
|
= traverse (completeValue listType fields) list
|
||||||
|
>>= coerceResult outputType . List
|
||||||
|
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =
|
||||||
|
coerceResult outputType $ Int int
|
||||||
|
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =
|
||||||
|
coerceResult outputType $ Boolean boolean
|
||||||
|
completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
|
||||||
|
coerceResult outputType $ Float float
|
||||||
|
completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
|
||||||
|
coerceResult outputType $ String string
|
||||||
|
completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
|
||||||
|
let Type.EnumType _ _ enumMembers = enumType
|
||||||
|
in if HashMap.member enum enumMembers
|
||||||
|
then coerceResult outputType $ Enum enum
|
||||||
|
else errmsg "Value completion failed."
|
||||||
|
completeValue (Out.ObjectBaseType objectType) fields result =
|
||||||
|
executeSelectionSet result objectType $ mergeSelectionSets fields
|
||||||
|
completeValue (Out.InterfaceBaseType interfaceType) fields result
|
||||||
|
| Type.Object objectMap <- result = do
|
||||||
|
let abstractType = AbstractInterfaceType interfaceType
|
||||||
|
concreteType <- resolveAbstractType abstractType objectMap
|
||||||
|
case concreteType of
|
||||||
|
Just objectType -> executeSelectionSet result objectType
|
||||||
|
$ mergeSelectionSets fields
|
||||||
|
Nothing -> errmsg "Value completion failed."
|
||||||
|
completeValue (Out.UnionBaseType unionType) fields result
|
||||||
|
| Type.Object objectMap <- result = do
|
||||||
|
let abstractType = AbstractUnionType unionType
|
||||||
|
concreteType <- resolveAbstractType abstractType objectMap
|
||||||
|
case concreteType of
|
||||||
|
Just objectType -> executeSelectionSet result objectType
|
||||||
|
$ mergeSelectionSets fields
|
||||||
|
Nothing -> errmsg "Value completion failed."
|
||||||
|
completeValue _ _ _ = errmsg "Value completion failed."
|
||||||
|
|
||||||
|
mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)
|
||||||
|
mergeSelectionSets = foldr forEach mempty
|
||||||
|
where
|
||||||
|
forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
|
||||||
|
selectionSet <> fieldSelectionSet
|
||||||
|
|
||||||
|
errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
|
||||||
|
errmsg errorMessage = addErrMsg errorMessage >> pure null
|
||||||
|
|
||||||
|
coerceResult :: (Monad m, Serialize a)
|
||||||
|
=> Out.Type m
|
||||||
|
-> Output a
|
||||||
|
-> CollectErrsT m a
|
||||||
|
coerceResult outputType result
|
||||||
|
| Just serialized <- serialize outputType result = pure serialized
|
||||||
|
| otherwise = errmsg "Result coercion failed."
|
||||||
|
|
||||||
|
-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
|
||||||
|
-- each field to each 'Transform.Selection'. Resolves into a value containing
|
||||||
|
-- the resolved 'Transform.Selection', or a null value and error information.
|
||||||
|
executeSelectionSet :: (Monad m, Serialize a)
|
||||||
|
=> Type.Value
|
||||||
|
-> Out.ObjectType m
|
||||||
|
-> Seq (Transform.Selection m)
|
||||||
|
-> CollectErrsT m a
|
||||||
|
executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
|
||||||
|
let fields = collectFields objectType selectionSet
|
||||||
|
resolvedValues <- Map.traverseMaybeWithKey forEach fields
|
||||||
|
coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
|
||||||
|
where
|
||||||
|
forEach _ fields@(field :| _) =
|
||||||
|
let Transform.Field _ name _ _ = field
|
||||||
|
in traverse (tryResolver fields) $ lookupResolver name
|
||||||
|
lookupResolver = flip HashMap.lookup resolvers
|
||||||
|
tryResolver fields resolver =
|
||||||
|
executeField resolver result fields >>= lift . pure
|
||||||
|
|
||||||
|
coerceArgumentValues
|
||||||
|
:: HashMap Name In.Argument
|
||||||
|
-> HashMap Name Transform.Input
|
||||||
|
-> Maybe Type.Subs
|
||||||
|
coerceArgumentValues argumentDefinitions argumentValues =
|
||||||
|
HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
|
||||||
|
where
|
||||||
|
forEach variableName (In.Argument _ variableType defaultValue) =
|
||||||
|
matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue
|
||||||
|
coerceArgumentValue inputType (Transform.Int integer) =
|
||||||
|
coerceInputLiteral inputType (Type.Int integer)
|
||||||
|
coerceArgumentValue inputType (Transform.Boolean boolean) =
|
||||||
|
coerceInputLiteral inputType (Type.Boolean boolean)
|
||||||
|
coerceArgumentValue inputType (Transform.String string) =
|
||||||
|
coerceInputLiteral inputType (Type.String string)
|
||||||
|
coerceArgumentValue inputType (Transform.Float float) =
|
||||||
|
coerceInputLiteral inputType (Type.Float float)
|
||||||
|
coerceArgumentValue inputType (Transform.Enum enum) =
|
||||||
|
coerceInputLiteral inputType (Type.Enum enum)
|
||||||
|
coerceArgumentValue inputType Transform.Null
|
||||||
|
| In.isNonNullType inputType = Nothing
|
||||||
|
| otherwise = coerceInputLiteral inputType Type.Null
|
||||||
|
coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
|
||||||
|
let coerceItem = coerceInputLiteral inputType
|
||||||
|
in Type.List <$> traverse coerceItem list
|
||||||
|
coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
|
||||||
|
| In.InputObjectType _ _ inputFields <- inputType =
|
||||||
|
let go = forEachField object
|
||||||
|
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
|
||||||
|
in Type.Object <$> resultMap
|
||||||
|
coerceArgumentValue _ (Transform.Variable variable) = pure variable
|
||||||
|
coerceArgumentValue _ _ = Nothing
|
||||||
|
forEachField object variableName (In.InputField _ variableType defaultValue) =
|
||||||
|
matchFieldValues coerceArgumentValue object variableName variableType defaultValue
|
|
@ -1,125 +1,356 @@
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
-- | After the document is parsed, before getting executed the AST is
|
-- | After the document is parsed, before getting executed, the AST is
|
||||||
-- transformed into a similar, simpler AST. This module is responsible for
|
-- transformed into a similar, simpler AST. Performed transformations include:
|
||||||
-- this transformation.
|
--
|
||||||
|
-- * Replacing variables with their values.
|
||||||
|
-- * Inlining fragments. Some fragments can be completely eliminated and
|
||||||
|
-- replaced by the selection set they represent. Invalid (recursive and
|
||||||
|
-- non-existing) fragments are skipped. The most fragments are inlined, so the
|
||||||
|
-- executor doesn't have to perform additional lookups later.
|
||||||
|
-- * Evaluating directives (@\@include@ and @\@skip@).
|
||||||
|
--
|
||||||
|
-- This module is also responsible for smaller rewrites that touch only parts of
|
||||||
|
-- the original AST.
|
||||||
module Language.GraphQL.Execute.Transform
|
module Language.GraphQL.Execute.Transform
|
||||||
( document
|
( Document(..)
|
||||||
|
, Field(..)
|
||||||
|
, Fragment(..)
|
||||||
|
, Input(..)
|
||||||
|
, Operation(..)
|
||||||
|
, QueryError(..)
|
||||||
|
, Selection(..)
|
||||||
|
, document
|
||||||
|
, queryError
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Arrow (first)
|
|
||||||
import Control.Monad (foldM, unless)
|
import Control.Monad (foldM, unless)
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Monad.Trans.Class (lift)
|
||||||
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
|
import Control.Monad.Trans.State (State, evalStateT, gets, modify)
|
||||||
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
import Data.Foldable (find)
|
||||||
|
import Data.Functor.Identity (Identity(..))
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Data.Int (Int32)
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import qualified Data.List.NonEmpty as NonEmpty
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
import Data.Sequence (Seq, (<|), (><))
|
import Data.Sequence (Seq, (<|), (><))
|
||||||
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text as Text
|
||||||
import qualified Language.GraphQL.AST as Full
|
import qualified Language.GraphQL.AST as Full
|
||||||
import qualified Language.GraphQL.AST.Core as Core
|
import Language.GraphQL.AST (Name)
|
||||||
import Language.GraphQL.AST.Document (Definition(..), Document)
|
import Language.GraphQL.AST.Core
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
import qualified Language.GraphQL.Execute.Coerce as Coerce
|
||||||
|
import Language.GraphQL.Type.Directive (Directive(..))
|
||||||
import qualified Language.GraphQL.Type.Directive as Directive
|
import qualified Language.GraphQL.Type.Directive as Directive
|
||||||
|
import qualified Language.GraphQL.Type as Type
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
import Language.GraphQL.Type.Schema
|
||||||
|
|
||||||
-- | Associates a fragment name with a list of 'Core.Field's.
|
-- | Associates a fragment name with a list of 'Field's.
|
||||||
data Replacement = Replacement
|
data Replacement m = Replacement
|
||||||
{ fragments :: HashMap Core.Name Core.Fragment
|
{ fragments :: HashMap Full.Name (Fragment m)
|
||||||
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
|
, fragmentDefinitions :: FragmentDefinitions
|
||||||
|
, variableValues :: Type.Subs
|
||||||
|
, types :: HashMap Full.Name (Type m)
|
||||||
}
|
}
|
||||||
|
|
||||||
type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
|
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
|
||||||
|
|
||||||
liftJust :: forall a. a -> TransformT a
|
-- | Represents fragments and inline fragments.
|
||||||
liftJust = lift . lift . Just
|
data Fragment m
|
||||||
|
= Fragment (CompositeType m) (Seq (Selection m))
|
||||||
|
|
||||||
|
-- | Single selection element.
|
||||||
|
data Selection m
|
||||||
|
= SelectionFragment (Fragment m)
|
||||||
|
| SelectionField (Field m)
|
||||||
|
|
||||||
|
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
|
||||||
|
--
|
||||||
|
-- Currently only queries and mutations are supported.
|
||||||
|
data Operation m
|
||||||
|
= Query (Maybe Text) (Seq (Selection m))
|
||||||
|
| Mutation (Maybe Text) (Seq (Selection m))
|
||||||
|
|
||||||
|
-- | Single GraphQL field.
|
||||||
|
data Field m = Field
|
||||||
|
(Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
|
||||||
|
|
||||||
|
-- | Contains the operation to be executed along with its root type.
|
||||||
|
data Document m = Document
|
||||||
|
(HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
|
||||||
|
|
||||||
|
data OperationDefinition = OperationDefinition
|
||||||
|
Full.OperationType
|
||||||
|
(Maybe Full.Name)
|
||||||
|
[Full.VariableDefinition]
|
||||||
|
[Full.Directive]
|
||||||
|
Full.SelectionSet
|
||||||
|
|
||||||
|
-- | Query error types.
|
||||||
|
data QueryError
|
||||||
|
= OperationNotFound Text
|
||||||
|
| OperationNameRequired
|
||||||
|
| CoercionError
|
||||||
|
| TransformationError
|
||||||
|
| EmptyDocument
|
||||||
|
| UnsupportedRootOperation
|
||||||
|
|
||||||
|
data Input
|
||||||
|
= Int Int32
|
||||||
|
| Float Double
|
||||||
|
| String Text
|
||||||
|
| Boolean Bool
|
||||||
|
| Null
|
||||||
|
| Enum Name
|
||||||
|
| List [Type.Value]
|
||||||
|
| Object (HashMap Name Input)
|
||||||
|
| Variable Type.Value
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
queryError :: QueryError -> Text
|
||||||
|
queryError (OperationNotFound operationName) = Text.unwords
|
||||||
|
["Operation", operationName, "couldn't be found in the document."]
|
||||||
|
queryError OperationNameRequired = "Missing operation name."
|
||||||
|
queryError CoercionError = "Coercion error."
|
||||||
|
queryError TransformationError = "Schema transformation error."
|
||||||
|
queryError EmptyDocument =
|
||||||
|
"The document doesn't contain any executable operations."
|
||||||
|
queryError UnsupportedRootOperation =
|
||||||
|
"Root operation type couldn't be found in the schema."
|
||||||
|
|
||||||
|
getOperation
|
||||||
|
:: Maybe Full.Name
|
||||||
|
-> NonEmpty OperationDefinition
|
||||||
|
-> Either QueryError OperationDefinition
|
||||||
|
getOperation Nothing (operation' :| []) = pure operation'
|
||||||
|
getOperation Nothing _ = Left OperationNameRequired
|
||||||
|
getOperation (Just operationName) operations
|
||||||
|
| Just operation' <- find matchingName operations = pure operation'
|
||||||
|
| otherwise = Left $ OperationNotFound operationName
|
||||||
|
where
|
||||||
|
matchingName (OperationDefinition _ name _ _ _) =
|
||||||
|
name == Just operationName
|
||||||
|
|
||||||
|
lookupInputType
|
||||||
|
:: Full.Type
|
||||||
|
-> HashMap.HashMap Full.Name (Type m)
|
||||||
|
-> Maybe In.Type
|
||||||
|
lookupInputType (Full.TypeNamed name) types =
|
||||||
|
case HashMap.lookup name types of
|
||||||
|
Just (ScalarType scalarType) ->
|
||||||
|
Just $ In.NamedScalarType scalarType
|
||||||
|
Just (EnumType enumType) ->
|
||||||
|
Just $ In.NamedEnumType enumType
|
||||||
|
Just (InputObjectType objectType) ->
|
||||||
|
Just $ In.NamedInputObjectType objectType
|
||||||
|
_ -> Nothing
|
||||||
|
lookupInputType (Full.TypeList list) types
|
||||||
|
= In.ListType
|
||||||
|
<$> lookupInputType list types
|
||||||
|
lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
|
||||||
|
case HashMap.lookup nonNull types of
|
||||||
|
Just (ScalarType scalarType) ->
|
||||||
|
Just $ In.NonNullScalarType scalarType
|
||||||
|
Just (EnumType enumType) ->
|
||||||
|
Just $ In.NonNullEnumType enumType
|
||||||
|
Just (InputObjectType objectType) ->
|
||||||
|
Just $ In.NonNullInputObjectType objectType
|
||||||
|
_ -> Nothing
|
||||||
|
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
|
||||||
|
= In.NonNullListType
|
||||||
|
<$> lookupInputType nonNull types
|
||||||
|
|
||||||
|
coerceVariableValues :: Coerce.VariableValue a
|
||||||
|
=> forall m
|
||||||
|
. HashMap Full.Name (Type m)
|
||||||
|
-> OperationDefinition
|
||||||
|
-> HashMap.HashMap Full.Name a
|
||||||
|
-> Either QueryError Type.Subs
|
||||||
|
coerceVariableValues types operationDefinition variableValues =
|
||||||
|
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
|
||||||
|
in maybe (Left CoercionError) Right
|
||||||
|
$ foldr forEach (Just HashMap.empty) variableDefinitions
|
||||||
|
where
|
||||||
|
forEach variableDefinition coercedValues = do
|
||||||
|
let Full.VariableDefinition variableName variableTypeName defaultValue =
|
||||||
|
variableDefinition
|
||||||
|
let defaultValue' = constValue <$> defaultValue
|
||||||
|
variableType <- lookupInputType variableTypeName types
|
||||||
|
|
||||||
|
Coerce.matchFieldValues
|
||||||
|
coerceVariableValue'
|
||||||
|
variableValues
|
||||||
|
variableName
|
||||||
|
variableType
|
||||||
|
defaultValue'
|
||||||
|
coercedValues
|
||||||
|
coerceVariableValue' variableType value'
|
||||||
|
= Coerce.coerceVariableValue variableType value'
|
||||||
|
>>= Coerce.coerceInputLiteral variableType
|
||||||
|
|
||||||
|
constValue :: Full.ConstValue -> Type.Value
|
||||||
|
constValue (Full.ConstInt i) = Type.Int i
|
||||||
|
constValue (Full.ConstFloat f) = Type.Float f
|
||||||
|
constValue (Full.ConstString x) = Type.String x
|
||||||
|
constValue (Full.ConstBoolean b) = Type.Boolean b
|
||||||
|
constValue Full.ConstNull = Type.Null
|
||||||
|
constValue (Full.ConstEnum e) = Type.Enum e
|
||||||
|
constValue (Full.ConstList l) = Type.List $ constValue <$> l
|
||||||
|
constValue (Full.ConstObject o) =
|
||||||
|
Type.Object $ HashMap.fromList $ constObjectField <$> o
|
||||||
|
where
|
||||||
|
constObjectField (Full.ObjectField key value') = (key, constValue value')
|
||||||
|
|
||||||
-- | Rewrites the original syntax tree into an intermediate representation used
|
-- | Rewrites the original syntax tree into an intermediate representation used
|
||||||
-- for query execution.
|
-- for query execution.
|
||||||
document :: Schema.Subs -> Document -> Maybe Core.Document
|
document :: Coerce.VariableValue a
|
||||||
document subs document' =
|
=> forall m
|
||||||
flip runReaderT subs
|
. Schema m
|
||||||
$ evalStateT (collectFragments >> operations operationDefinitions)
|
-> Maybe Full.Name
|
||||||
$ Replacement HashMap.empty fragmentTable
|
-> HashMap Full.Name a
|
||||||
|
-> Full.Document
|
||||||
|
-> Either QueryError (Document m)
|
||||||
|
document schema operationName subs ast = do
|
||||||
|
let referencedTypes = collectReferencedTypes schema
|
||||||
|
|
||||||
|
(operations, fragmentTable) <- defragment ast
|
||||||
|
chosenOperation <- getOperation operationName operations
|
||||||
|
coercedValues <- coerceVariableValues referencedTypes chosenOperation subs
|
||||||
|
|
||||||
|
let replacement = Replacement
|
||||||
|
{ fragments = HashMap.empty
|
||||||
|
, fragmentDefinitions = fragmentTable
|
||||||
|
, variableValues = coercedValues
|
||||||
|
, types = referencedTypes
|
||||||
|
}
|
||||||
|
case chosenOperation of
|
||||||
|
OperationDefinition Full.Query _ _ _ _ ->
|
||||||
|
pure $ Document referencedTypes (query schema)
|
||||||
|
$ operation chosenOperation replacement
|
||||||
|
OperationDefinition Full.Mutation _ _ _ _
|
||||||
|
| Just mutationType <- mutation schema ->
|
||||||
|
pure $ Document referencedTypes mutationType
|
||||||
|
$ operation chosenOperation replacement
|
||||||
|
_ -> Left UnsupportedRootOperation
|
||||||
|
|
||||||
|
defragment
|
||||||
|
:: Full.Document
|
||||||
|
-> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions)
|
||||||
|
defragment ast =
|
||||||
|
let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast
|
||||||
|
nonEmptyOperations = NonEmpty.nonEmpty operations
|
||||||
|
emptyDocument = Left EmptyDocument
|
||||||
|
in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
|
||||||
where
|
where
|
||||||
(fragmentTable, operationDefinitions) = foldr defragment mempty document'
|
defragment' definition (operations, fragments')
|
||||||
defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
|
| (Full.ExecutableDefinition executable) <- definition
|
||||||
(definition :) <$> acc
|
, (Full.DefinitionOperation operation') <- executable =
|
||||||
defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
|
(transform operation' : operations, fragments')
|
||||||
let (Full.FragmentDefinition name _ _ _) = definition
|
| (Full.ExecutableDefinition executable) <- definition
|
||||||
in first (HashMap.insert name definition) acc
|
, (Full.DefinitionFragment fragment) <- executable
|
||||||
defragment _ acc = acc
|
, (Full.FragmentDefinition name _ _ _) <- fragment =
|
||||||
|
(operations, HashMap.insert name fragment fragments')
|
||||||
|
defragment' _ acc = acc
|
||||||
|
transform = \case
|
||||||
|
Full.OperationDefinition type' name variables directives' selections ->
|
||||||
|
OperationDefinition type' name variables directives' selections
|
||||||
|
Full.SelectionSet selectionSet ->
|
||||||
|
OperationDefinition Full.Query Nothing mempty mempty selectionSet
|
||||||
|
|
||||||
-- * Operation
|
-- * Operation
|
||||||
|
|
||||||
operations :: [Full.OperationDefinition] -> TransformT Core.Document
|
operation :: OperationDefinition -> Replacement m -> Operation m
|
||||||
operations operations' = do
|
operation operationDefinition replacement
|
||||||
coreOperations <- traverse operation operations'
|
= runIdentity
|
||||||
lift . lift $ NonEmpty.nonEmpty coreOperations
|
$ evalStateT (collectFragments >> transform operationDefinition) replacement
|
||||||
|
where
|
||||||
operation :: Full.OperationDefinition -> TransformT Core.Operation
|
transform (OperationDefinition Full.Query name _ _ sels) =
|
||||||
operation (Full.SelectionSet sels)
|
Query name <$> appendSelection sels
|
||||||
= operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
|
transform (OperationDefinition Full.Mutation name _ _ sels) =
|
||||||
operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
|
Mutation name <$> appendSelection sels
|
||||||
= Core.Query name <$> appendSelection sels
|
|
||||||
operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
|
|
||||||
= Core.Mutation name <$> appendSelection sels
|
|
||||||
|
|
||||||
-- * Selection
|
-- * Selection
|
||||||
|
|
||||||
selection ::
|
selection
|
||||||
Full.Selection ->
|
:: Full.Selection
|
||||||
TransformT (Either (Seq Core.Selection) Core.Selection)
|
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
||||||
selection (Full.Field alias name arguments' directives' selections) =
|
selection (Full.Field alias name arguments' directives' selections) =
|
||||||
maybe (Left mempty) (Right . Core.SelectionField) <$> do
|
maybe (Left mempty) (Right . SelectionField) <$> do
|
||||||
fieldArguments <- arguments arguments'
|
fieldArguments <- foldM go HashMap.empty arguments'
|
||||||
fieldSelections <- appendSelection selections
|
fieldSelections <- appendSelection selections
|
||||||
fieldDirectives <- Directive.selection <$> directives directives'
|
fieldDirectives <- Directive.selection <$> directives directives'
|
||||||
let field' = Core.Field alias name fieldArguments fieldSelections
|
let field' = Field alias name fieldArguments fieldSelections
|
||||||
pure $ field' <$ fieldDirectives
|
pure $ field' <$ fieldDirectives
|
||||||
|
where
|
||||||
|
go arguments (Full.Argument name' value') =
|
||||||
|
inputField arguments name' value'
|
||||||
|
|
||||||
selection (Full.FragmentSpread name directives') =
|
selection (Full.FragmentSpread name directives') =
|
||||||
maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
|
maybe (Left mempty) (Right . SelectionFragment) <$> do
|
||||||
spreadDirectives <- Directive.selection <$> directives directives'
|
spreadDirectives <- Directive.selection <$> directives directives'
|
||||||
fragments' <- gets fragments
|
fragments' <- gets fragments
|
||||||
fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
|
|
||||||
pure $ fragment <$ spreadDirectives
|
|
||||||
where
|
|
||||||
lookupDefinition = do
|
|
||||||
fragmentDefinitions' <- gets fragmentDefinitions
|
fragmentDefinitions' <- gets fragmentDefinitions
|
||||||
found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
|
case HashMap.lookup name fragments' of
|
||||||
fragmentDefinition found
|
Just definition -> lift $ pure $ definition <$ spreadDirectives
|
||||||
|
Nothing
|
||||||
|
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
|
||||||
|
fragDef <- fragmentDefinition definition
|
||||||
|
case fragDef of
|
||||||
|
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
|
||||||
|
_ -> lift $ pure Nothing
|
||||||
|
| otherwise -> lift $ pure Nothing
|
||||||
selection (Full.InlineFragment type' directives' selections) = do
|
selection (Full.InlineFragment type' directives' selections) = do
|
||||||
fragmentDirectives <- Directive.selection <$> directives directives'
|
fragmentDirectives <- Directive.selection <$> directives directives'
|
||||||
case fragmentDirectives of
|
case fragmentDirectives of
|
||||||
Nothing -> pure $ Left mempty
|
Nothing -> pure $ Left mempty
|
||||||
_ -> do
|
_ -> do
|
||||||
fragmentSelectionSet <- appendSelection selections
|
fragmentSelectionSet <- appendSelection selections
|
||||||
pure $ maybe Left selectionFragment type' fragmentSelectionSet
|
|
||||||
|
case type' of
|
||||||
|
Nothing -> pure $ Left fragmentSelectionSet
|
||||||
|
Just typeName -> do
|
||||||
|
typeCondition' <- lookupTypeCondition typeName
|
||||||
|
case typeCondition' of
|
||||||
|
Just typeCondition -> pure $
|
||||||
|
selectionFragment typeCondition fragmentSelectionSet
|
||||||
|
Nothing -> pure $ Left mempty
|
||||||
where
|
where
|
||||||
selectionFragment typeName = Right
|
selectionFragment typeName = Right
|
||||||
. Core.SelectionFragment
|
. SelectionFragment
|
||||||
. Core.Fragment typeName
|
. Fragment typeName
|
||||||
|
|
||||||
appendSelection ::
|
appendSelection :: Traversable t
|
||||||
Traversable t =>
|
=> t Full.Selection
|
||||||
t Full.Selection ->
|
-> State (Replacement m) (Seq (Selection m))
|
||||||
TransformT (Seq Core.Selection)
|
|
||||||
appendSelection = foldM go mempty
|
appendSelection = foldM go mempty
|
||||||
where
|
where
|
||||||
go acc sel = append acc <$> selection sel
|
go acc sel = append acc <$> selection sel
|
||||||
append acc (Left list) = list >< acc
|
append acc (Left list) = list >< acc
|
||||||
append acc (Right one) = one <| acc
|
append acc (Right one) = one <| acc
|
||||||
|
|
||||||
directives :: [Full.Directive] -> TransformT [Core.Directive]
|
directives :: [Full.Directive] -> State (Replacement m) [Directive]
|
||||||
directives = traverse directive
|
directives = traverse directive
|
||||||
where
|
where
|
||||||
directive (Full.Directive directiveName directiveArguments) =
|
directive (Full.Directive directiveName directiveArguments)
|
||||||
Core.Directive directiveName <$> arguments directiveArguments
|
= Directive directiveName . Arguments
|
||||||
|
<$> foldM go HashMap.empty directiveArguments
|
||||||
|
go arguments (Full.Argument name value') = do
|
||||||
|
substitutedValue <- value value'
|
||||||
|
return $ HashMap.insert name substitutedValue arguments
|
||||||
|
|
||||||
-- * Fragment replacement
|
-- * Fragment replacement
|
||||||
|
|
||||||
-- | Extract fragment definitions into a single 'HashMap'.
|
-- | Extract fragment definitions into a single 'HashMap'.
|
||||||
collectFragments :: TransformT ()
|
collectFragments :: State (Replacement m) ()
|
||||||
collectFragments = do
|
collectFragments = do
|
||||||
fragDefs <- gets fragmentDefinitions
|
fragDefs <- gets fragmentDefinitions
|
||||||
let nextValue = head $ HashMap.elems fragDefs
|
let nextValue = head $ HashMap.elems fragDefs
|
||||||
|
@ -127,41 +358,79 @@ collectFragments = do
|
||||||
_ <- fragmentDefinition nextValue
|
_ <- fragmentDefinition nextValue
|
||||||
collectFragments
|
collectFragments
|
||||||
|
|
||||||
fragmentDefinition ::
|
lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m))
|
||||||
Full.FragmentDefinition ->
|
lookupTypeCondition type' = do
|
||||||
TransformT Core.Fragment
|
types' <- gets types
|
||||||
|
case HashMap.lookup type' types' of
|
||||||
|
Just (ObjectType objectType) ->
|
||||||
|
lift $ pure $ Just $ CompositeObjectType objectType
|
||||||
|
Just (UnionType unionType) ->
|
||||||
|
lift $ pure $ Just $ CompositeUnionType unionType
|
||||||
|
Just (InterfaceType interfaceType) ->
|
||||||
|
lift $ pure $ Just $ CompositeInterfaceType interfaceType
|
||||||
|
_ -> lift $ pure Nothing
|
||||||
|
|
||||||
|
fragmentDefinition
|
||||||
|
:: Full.FragmentDefinition
|
||||||
|
-> State (Replacement m) (Maybe (Fragment m))
|
||||||
fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
|
fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
|
||||||
modify deleteFragmentDefinition
|
modify deleteFragmentDefinition
|
||||||
fragmentSelection <- appendSelection selections
|
fragmentSelection <- appendSelection selections
|
||||||
let newValue = Core.Fragment type' fragmentSelection
|
compositeType <- lookupTypeCondition type'
|
||||||
modify $ insertFragment newValue
|
|
||||||
liftJust newValue
|
case compositeType of
|
||||||
|
Just compositeType' -> do
|
||||||
|
let newValue = Fragment compositeType' fragmentSelection
|
||||||
|
modify $ insertFragment newValue
|
||||||
|
lift $ pure $ Just newValue
|
||||||
|
_ -> lift $ pure Nothing
|
||||||
where
|
where
|
||||||
deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
|
deleteFragmentDefinition replacement@Replacement{..} =
|
||||||
Replacement fragments' $ HashMap.delete name fragmentDefinitions'
|
let newDefinitions = HashMap.delete name fragmentDefinitions
|
||||||
insertFragment newValue (Replacement fragments' fragmentDefinitions') =
|
in replacement{ fragmentDefinitions = newDefinitions }
|
||||||
let newFragments = HashMap.insert name newValue fragments'
|
insertFragment newValue replacement@Replacement{..} =
|
||||||
in Replacement newFragments fragmentDefinitions'
|
let newFragments = HashMap.insert name newValue fragments
|
||||||
|
in replacement{ fragments = newFragments }
|
||||||
|
|
||||||
arguments :: [Full.Argument] -> TransformT Core.Arguments
|
value :: forall m. Full.Value -> State (Replacement m) Type.Value
|
||||||
arguments = fmap Core.Arguments . foldM go HashMap.empty
|
value (Full.Variable name) =
|
||||||
|
gets (fromMaybe Type.Null . HashMap.lookup name . variableValues)
|
||||||
|
value (Full.Int int) = pure $ Type.Int int
|
||||||
|
value (Full.Float float) = pure $ Type.Float float
|
||||||
|
value (Full.String string) = pure $ Type.String string
|
||||||
|
value (Full.Boolean boolean) = pure $ Type.Boolean boolean
|
||||||
|
value Full.Null = pure Type.Null
|
||||||
|
value (Full.Enum enum) = pure $ Type.Enum enum
|
||||||
|
value (Full.List list) = Type.List <$> traverse value list
|
||||||
|
value (Full.Object object) =
|
||||||
|
Type.Object . HashMap.fromList <$> traverse objectField object
|
||||||
where
|
where
|
||||||
go arguments' (Full.Argument name value') = do
|
objectField (Full.ObjectField name value') = (name,) <$> value value'
|
||||||
substitutedValue <- value value'
|
|
||||||
return $ HashMap.insert name substitutedValue arguments'
|
|
||||||
|
|
||||||
value :: Full.Value -> TransformT Core.Value
|
input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
|
||||||
value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
|
input (Full.Variable name) =
|
||||||
value (Full.Int i) = pure $ Core.Int i
|
gets (fmap Variable . HashMap.lookup name . variableValues)
|
||||||
value (Full.Float f) = pure $ Core.Float f
|
input (Full.Int int) = pure $ pure $ Int int
|
||||||
value (Full.String x) = pure $ Core.String x
|
input (Full.Float float) = pure $ pure $ Float float
|
||||||
value (Full.Boolean b) = pure $ Core.Boolean b
|
input (Full.String string) = pure $ pure $ String string
|
||||||
value Full.Null = pure Core.Null
|
input (Full.Boolean boolean) = pure $ pure $ Boolean boolean
|
||||||
value (Full.Enum e) = pure $ Core.Enum e
|
input Full.Null = pure $ pure Null
|
||||||
value (Full.List l) =
|
input (Full.Enum enum) = pure $ pure $ Enum enum
|
||||||
Core.List <$> traverse value l
|
input (Full.List list) = pure . List <$> traverse value list
|
||||||
value (Full.Object o) =
|
input (Full.Object object) = do
|
||||||
Core.Object . HashMap.fromList <$> traverse objectField o
|
objectFields <- foldM objectField HashMap.empty object
|
||||||
|
pure $ pure $ Object objectFields
|
||||||
|
where
|
||||||
|
objectField resultMap (Full.ObjectField name value') =
|
||||||
|
inputField resultMap name value'
|
||||||
|
|
||||||
objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
|
inputField :: forall m
|
||||||
objectField (Full.ObjectField name value') = (name,) <$> value value'
|
. HashMap Full.Name Input
|
||||||
|
-> Full.Name
|
||||||
|
-> Full.Value
|
||||||
|
-> State (Replacement m) (HashMap Full.Name Input)
|
||||||
|
inputField resultMap name value' = do
|
||||||
|
objectFieldValue <- input value'
|
||||||
|
case objectFieldValue of
|
||||||
|
Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap
|
||||||
|
Nothing -> pure resultMap
|
||||||
|
|
|
@ -1,138 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
|
||||||
-- functions for defining and manipulating schemas.
|
|
||||||
module Language.GraphQL.Schema
|
|
||||||
( Resolver(..)
|
|
||||||
, Subs
|
|
||||||
, object
|
|
||||||
, resolve
|
|
||||||
, resolversToMap
|
|
||||||
, scalar
|
|
||||||
, wrappedObject
|
|
||||||
, wrappedScalar
|
|
||||||
-- * AST Reexports
|
|
||||||
, Field
|
|
||||||
, Value(..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad.Trans.Class (lift)
|
|
||||||
import Control.Monad.Trans.Except (runExceptT)
|
|
||||||
import Control.Monad.Trans.Reader (runReaderT)
|
|
||||||
import Data.Foldable (fold, toList)
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import qualified Data.Aeson as Aeson
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
|
||||||
import Data.Sequence (Seq)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Language.GraphQL.AST.Core
|
|
||||||
import Language.GraphQL.Error
|
|
||||||
import Language.GraphQL.Trans
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
-- | 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)
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
-- | 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)
|
|
||||||
-> 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
|
|
||||||
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
|
|
||||||
|
|
||||||
aliasOrName :: Field -> Text
|
|
||||||
aliasOrName (Field alias name _ _) = fromMaybe name alias
|
|
|
@ -1,8 +1,8 @@
|
||||||
-- | Monad transformer stack used by the @GraphQL@ resolvers.
|
-- | Monad transformer stack used by the @GraphQL@ resolvers.
|
||||||
module Language.GraphQL.Trans
|
module Language.GraphQL.Trans
|
||||||
( ActionT(..)
|
( argument
|
||||||
|
, ActionT(..)
|
||||||
, Context(..)
|
, Context(..)
|
||||||
, argument
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative (Alternative(..))
|
import Control.Applicative (Alternative(..))
|
||||||
|
@ -14,12 +14,15 @@ import Control.Monad.Trans.Reader (ReaderT, asks)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Language.GraphQL.AST (Name)
|
||||||
import Language.GraphQL.AST.Core
|
import Language.GraphQL.AST.Core
|
||||||
|
import Language.GraphQL.Type.Definition
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
|
|
||||||
-- | Resolution context holds resolver arguments.
|
-- | Resolution context holds resolver arguments.
|
||||||
newtype Context = Context
|
data Context = Context
|
||||||
{ arguments :: Arguments
|
{ arguments :: Arguments
|
||||||
|
, values :: Value
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Monad transformer stack used by the resolvers to provide error handling
|
-- | Monad transformer stack used by the resolvers to provide error handling
|
||||||
|
@ -54,7 +57,7 @@ instance Monad m => MonadPlus (ActionT m) where
|
||||||
mplus = (<|>)
|
mplus = (<|>)
|
||||||
|
|
||||||
-- | Retrieves an argument by its name. If the argument with this name couldn't
|
-- | Retrieves an argument by its name. If the argument with this name couldn't
|
||||||
-- be found, returns 'Value.Null' (i.e. the argument is assumed to
|
-- be found, returns 'Null' (i.e. the argument is assumed to
|
||||||
-- be optional then).
|
-- be optional then).
|
||||||
argument :: Monad m => Name -> ActionT m Value
|
argument :: Monad m => Name -> ActionT m Value
|
||||||
argument argumentName = do
|
argument argumentName = do
|
||||||
|
|
|
@ -1,55 +1,16 @@
|
||||||
-- | Definitions for @GraphQL@ input types.
|
-- | Reexports non-conflicting type system and schema definitions.
|
||||||
module Language.GraphQL.Type
|
module Language.GraphQL.Type
|
||||||
( Wrapping(..)
|
( In.InputField(..)
|
||||||
|
, In.InputObjectType(..)
|
||||||
|
, Out.Field(..)
|
||||||
|
, Out.InterfaceType(..)
|
||||||
|
, Out.ObjectType(..)
|
||||||
|
, Out.UnionType(..)
|
||||||
|
, module Language.GraphQL.Type.Definition
|
||||||
|
, module Language.GraphQL.Type.Schema
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Aeson as Aeson (ToJSON, toJSON)
|
import Language.GraphQL.Type.Definition
|
||||||
import qualified Data.Aeson as Aeson
|
import Language.GraphQL.Type.Schema (Schema(..))
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
-- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
-- 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
|
|
||||||
|
|
|
@ -0,0 +1,115 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
-- | Types that can be used as both input and output types.
|
||||||
|
module Language.GraphQL.Type.Definition
|
||||||
|
( EnumType(..)
|
||||||
|
, EnumValue(..)
|
||||||
|
, ScalarType(..)
|
||||||
|
, Subs
|
||||||
|
, Value(..)
|
||||||
|
, boolean
|
||||||
|
, float
|
||||||
|
, id
|
||||||
|
, int
|
||||||
|
, string
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Int (Int32)
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.String (IsString(..))
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Language.GraphQL.AST.Document (Name)
|
||||||
|
import Prelude hiding (id)
|
||||||
|
|
||||||
|
-- | Represents accordingly typed GraphQL values.
|
||||||
|
data Value
|
||||||
|
= Int Int32
|
||||||
|
| Float Double -- ^ GraphQL Float is double precision.
|
||||||
|
| String Text
|
||||||
|
| Boolean Bool
|
||||||
|
| Null
|
||||||
|
| Enum Name
|
||||||
|
| List [Value] -- ^ Arbitrary nested list.
|
||||||
|
| Object (HashMap Name Value)
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance IsString Value where
|
||||||
|
fromString = String . fromString
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
|
||||||
|
-- | Scalar type definition.
|
||||||
|
--
|
||||||
|
-- The leaf values of any request and input values to arguments are Scalars (or
|
||||||
|
-- Enums) .
|
||||||
|
data ScalarType = ScalarType Name (Maybe Text)
|
||||||
|
|
||||||
|
instance Eq ScalarType where
|
||||||
|
(ScalarType this _) == (ScalarType that _) = this == that
|
||||||
|
|
||||||
|
-- | Enum type definition.
|
||||||
|
--
|
||||||
|
-- Some leaf values of requests and input values are Enums. GraphQL serializes
|
||||||
|
-- Enum values as strings, however internally Enums can be represented by any
|
||||||
|
-- kind of type, often integers.
|
||||||
|
data EnumType = EnumType Name (Maybe Text) (HashMap Name EnumValue)
|
||||||
|
|
||||||
|
instance Eq EnumType where
|
||||||
|
(EnumType this _ _) == (EnumType that _ _) = this == that
|
||||||
|
|
||||||
|
-- | Enum value is a single member of an 'EnumType'.
|
||||||
|
newtype EnumValue = EnumValue (Maybe Text)
|
||||||
|
|
||||||
|
-- | The @String@ scalar type represents textual data, represented as UTF-8
|
||||||
|
-- character sequences. The String type is most often used by GraphQL to
|
||||||
|
-- represent free-form human-readable text.
|
||||||
|
string :: ScalarType
|
||||||
|
string = ScalarType "String" (Just description)
|
||||||
|
where
|
||||||
|
description =
|
||||||
|
"The `String` scalar type represents textual data, represented as \
|
||||||
|
\UTF-8 character sequences. The String type is most often used by \
|
||||||
|
\GraphQL to represent free-form human-readable text."
|
||||||
|
|
||||||
|
-- | The @Boolean@ scalar type represents @true@ or @false@.
|
||||||
|
boolean :: ScalarType
|
||||||
|
boolean = ScalarType "Boolean" (Just description)
|
||||||
|
where
|
||||||
|
description = "The `Boolean` scalar type represents `true` or `false`."
|
||||||
|
|
||||||
|
-- | The @Int@ scalar type represents non-fractional signed whole numeric
|
||||||
|
-- values. Int can represent values between \(-2^{31}\) and \(2^{31 - 1}\).
|
||||||
|
int :: ScalarType
|
||||||
|
int = ScalarType "Int" (Just description)
|
||||||
|
where
|
||||||
|
description =
|
||||||
|
"The `Int` scalar type represents non-fractional signed whole numeric \
|
||||||
|
\values. Int can represent values between -(2^31) and 2^31 - 1."
|
||||||
|
|
||||||
|
-- | The @Float@ scalar type represents signed double-precision fractional
|
||||||
|
-- values as specified by
|
||||||
|
-- [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point).
|
||||||
|
float :: ScalarType
|
||||||
|
float = ScalarType "Float" (Just description)
|
||||||
|
where
|
||||||
|
description =
|
||||||
|
"The `Float` scalar type represents signed double-precision fractional \
|
||||||
|
\values as specified by \
|
||||||
|
\[IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)."
|
||||||
|
|
||||||
|
-- | The @ID@ scalar type represents a unique identifier, often used to refetch
|
||||||
|
-- an object or as key for a cache. The ID type appears in a JSON response as a
|
||||||
|
-- String; however, it is not intended to be human-readable. When expected as an
|
||||||
|
-- input type, any string (such as @"4"@) or integer (such as @4@) input value
|
||||||
|
-- will be accepted as an ID.
|
||||||
|
id :: ScalarType
|
||||||
|
id = ScalarType "ID" (Just description)
|
||||||
|
where
|
||||||
|
description =
|
||||||
|
"The `ID` scalar type represents a unique identifier, often used to \
|
||||||
|
\refetch an object or as key for a cache. The ID type appears in a \
|
||||||
|
\JSON response as a String; however, it is not intended to be \
|
||||||
|
\human-readable. When expected as an input type, any string (such as \
|
||||||
|
\`\"4\"`) or integer (such as `4`) input value will be accepted as an ID."
|
|
@ -1,11 +1,18 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Language.GraphQL.Type.Directive
|
module Language.GraphQL.Type.Directive
|
||||||
( selection
|
( Directive(..)
|
||||||
|
, selection
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Language.GraphQL.AST (Name)
|
||||||
import Language.GraphQL.AST.Core
|
import Language.GraphQL.AST.Core
|
||||||
|
import Language.GraphQL.Type.Definition
|
||||||
|
|
||||||
|
-- | Directive.
|
||||||
|
data Directive = Directive Name Arguments
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | Directive processing status.
|
-- | Directive processing status.
|
||||||
data Status
|
data Status
|
||||||
|
|
|
@ -0,0 +1,101 @@
|
||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
-- | Input types and values.
|
||||||
|
--
|
||||||
|
-- This module is intended to be imported qualified, to avoid name clashes
|
||||||
|
-- with 'Language.GraphQL.Type.Out'.
|
||||||
|
module Language.GraphQL.Type.In
|
||||||
|
( Argument(..)
|
||||||
|
, InputField(..)
|
||||||
|
, InputObjectType(..)
|
||||||
|
, Type(..)
|
||||||
|
, isNonNullType
|
||||||
|
, pattern EnumBaseType
|
||||||
|
, pattern ListBaseType
|
||||||
|
, pattern InputObjectBaseType
|
||||||
|
, pattern ScalarBaseType
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Language.GraphQL.AST.Document (Name)
|
||||||
|
import Language.GraphQL.Type.Definition
|
||||||
|
|
||||||
|
-- | Single field of an 'InputObjectType'.
|
||||||
|
data InputField = InputField (Maybe Text) Type (Maybe Value)
|
||||||
|
|
||||||
|
-- | Input object type definition.
|
||||||
|
--
|
||||||
|
-- An input object defines a structured collection of fields which may be
|
||||||
|
-- supplied to a field argument.
|
||||||
|
data InputObjectType = InputObjectType
|
||||||
|
Name (Maybe Text) (HashMap Name InputField)
|
||||||
|
|
||||||
|
instance Eq InputObjectType where
|
||||||
|
(InputObjectType this _ _) == (InputObjectType that _ _) = this == that
|
||||||
|
|
||||||
|
-- | These types may be used as input types for arguments and directives.
|
||||||
|
--
|
||||||
|
-- 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).
|
||||||
|
data Type
|
||||||
|
= NamedScalarType ScalarType
|
||||||
|
| NamedEnumType EnumType
|
||||||
|
| NamedInputObjectType InputObjectType
|
||||||
|
| ListType Type
|
||||||
|
| NonNullScalarType ScalarType
|
||||||
|
| NonNullEnumType EnumType
|
||||||
|
| NonNullInputObjectType InputObjectType
|
||||||
|
| NonNullListType Type
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
|
-- | Field argument definition.
|
||||||
|
data Argument = Argument (Maybe Text) Type (Maybe Value)
|
||||||
|
|
||||||
|
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
||||||
|
pattern ScalarBaseType :: ScalarType -> Type
|
||||||
|
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
||||||
|
|
||||||
|
-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
|
||||||
|
pattern EnumBaseType :: EnumType -> Type
|
||||||
|
pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
|
||||||
|
|
||||||
|
-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
|
||||||
|
pattern InputObjectBaseType :: InputObjectType -> Type
|
||||||
|
pattern InputObjectBaseType objectType <- (isInputObjectType -> Just objectType)
|
||||||
|
|
||||||
|
-- | Matches either 'ListType' or 'NonNullListType'.
|
||||||
|
pattern ListBaseType :: Type -> Type
|
||||||
|
pattern ListBaseType listType <- (isListType -> Just listType)
|
||||||
|
|
||||||
|
{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
|
||||||
|
|
||||||
|
isScalarType :: Type -> Maybe ScalarType
|
||||||
|
isScalarType (NamedScalarType inputType) = Just inputType
|
||||||
|
isScalarType (NonNullScalarType inputType) = Just inputType
|
||||||
|
isScalarType _ = Nothing
|
||||||
|
|
||||||
|
isInputObjectType :: Type -> Maybe InputObjectType
|
||||||
|
isInputObjectType (NamedInputObjectType inputType) = Just inputType
|
||||||
|
isInputObjectType (NonNullInputObjectType inputType) = Just inputType
|
||||||
|
isInputObjectType _ = Nothing
|
||||||
|
|
||||||
|
isEnumType :: Type -> Maybe EnumType
|
||||||
|
isEnumType (NamedEnumType inputType) = Just inputType
|
||||||
|
isEnumType (NonNullEnumType inputType) = Just inputType
|
||||||
|
isEnumType _ = Nothing
|
||||||
|
|
||||||
|
isListType :: Type -> Maybe Type
|
||||||
|
isListType (ListType inputType) = Just inputType
|
||||||
|
isListType (NonNullListType inputType) = Just inputType
|
||||||
|
isListType _ = Nothing
|
||||||
|
|
||||||
|
-- | Checks whether the given input type is a non-null type.
|
||||||
|
isNonNullType :: Type -> Bool
|
||||||
|
isNonNullType (NonNullScalarType _) = True
|
||||||
|
isNonNullType (NonNullEnumType _) = True
|
||||||
|
isNonNullType (NonNullInputObjectType _) = True
|
||||||
|
isNonNullType (NonNullListType _) = True
|
||||||
|
isNonNullType _ = False
|
|
@ -0,0 +1,168 @@
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
-- | Output types and values.
|
||||||
|
--
|
||||||
|
-- This module is intended to be imported qualified, to avoid name clashes
|
||||||
|
-- with 'Language.GraphQL.Type.In'.
|
||||||
|
module Language.GraphQL.Type.Out
|
||||||
|
( Field(..)
|
||||||
|
, InterfaceType(..)
|
||||||
|
, ObjectType(..)
|
||||||
|
, Resolver(..)
|
||||||
|
, Type(..)
|
||||||
|
, UnionType(..)
|
||||||
|
, isNonNullType
|
||||||
|
, pattern EnumBaseType
|
||||||
|
, pattern InterfaceBaseType
|
||||||
|
, pattern ListBaseType
|
||||||
|
, pattern ObjectBaseType
|
||||||
|
, pattern ScalarBaseType
|
||||||
|
, pattern UnionBaseType
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Language.GraphQL.AST (Name)
|
||||||
|
import Language.GraphQL.Trans
|
||||||
|
import Language.GraphQL.Type.Definition
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
|
||||||
|
-- | 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'.
|
||||||
|
--
|
||||||
|
-- Resolving a field can result in a leaf value or an object, which is
|
||||||
|
-- represented as a list of nested resolvers, used to resolve the fields of that
|
||||||
|
-- object.
|
||||||
|
data Resolver m = Resolver (Field m) (ActionT m Value)
|
||||||
|
|
||||||
|
-- | 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 (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
|
||||||
|
|
||||||
|
instance forall a. Eq (ObjectType a) where
|
||||||
|
(ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
|
||||||
|
|
||||||
|
-- | Interface Type Definition.
|
||||||
|
--
|
||||||
|
-- When a field can return one of a heterogeneous set of types, a Interface type
|
||||||
|
-- is used to describe what types are possible, and what fields are in common
|
||||||
|
-- across all types.
|
||||||
|
data InterfaceType m = InterfaceType
|
||||||
|
Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
|
||||||
|
|
||||||
|
instance forall a. Eq (InterfaceType a) where
|
||||||
|
(InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that
|
||||||
|
|
||||||
|
-- | Union Type Definition.
|
||||||
|
--
|
||||||
|
-- When a field can return one of a heterogeneous set of types, a Union type is
|
||||||
|
-- used to describe what types are possible.
|
||||||
|
data UnionType m = UnionType Name (Maybe Text) [ObjectType m]
|
||||||
|
|
||||||
|
instance forall a. Eq (UnionType a) where
|
||||||
|
(UnionType this _ _) == (UnionType that _ _) = this == that
|
||||||
|
|
||||||
|
-- | Output object field definition.
|
||||||
|
data Field m = Field
|
||||||
|
(Maybe Text) -- ^ Description.
|
||||||
|
(Type m) -- ^ Field type.
|
||||||
|
(HashMap Name In.Argument) -- ^ Arguments.
|
||||||
|
|
||||||
|
-- | These types may be used as output types as the result of fields.
|
||||||
|
--
|
||||||
|
-- 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).
|
||||||
|
data Type m
|
||||||
|
= NamedScalarType ScalarType
|
||||||
|
| NamedEnumType EnumType
|
||||||
|
| NamedObjectType (ObjectType m)
|
||||||
|
| NamedInterfaceType (InterfaceType m)
|
||||||
|
| NamedUnionType (UnionType m)
|
||||||
|
| ListType (Type m)
|
||||||
|
| NonNullScalarType ScalarType
|
||||||
|
| NonNullEnumType EnumType
|
||||||
|
| NonNullObjectType (ObjectType m)
|
||||||
|
| NonNullInterfaceType (InterfaceType m)
|
||||||
|
| NonNullUnionType (UnionType m)
|
||||||
|
| NonNullListType (Type m)
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
|
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
||||||
|
pattern ScalarBaseType :: forall m. ScalarType -> Type m
|
||||||
|
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
||||||
|
|
||||||
|
-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
|
||||||
|
pattern EnumBaseType :: forall m. EnumType -> Type m
|
||||||
|
pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
|
||||||
|
|
||||||
|
-- | Matches either 'NamedObjectType' or 'NonNullObjectType'.
|
||||||
|
pattern ObjectBaseType :: forall m. ObjectType m -> Type m
|
||||||
|
pattern ObjectBaseType objectType <- (isObjectType -> Just objectType)
|
||||||
|
|
||||||
|
-- | Matches either 'NamedInterfaceType' or 'NonNullInterfaceType'.
|
||||||
|
pattern InterfaceBaseType :: forall m. InterfaceType m -> Type m
|
||||||
|
pattern InterfaceBaseType interfaceType <-
|
||||||
|
(isInterfaceType -> Just interfaceType)
|
||||||
|
|
||||||
|
-- | Matches either 'NamedUnionType' or 'NonNullUnionType'.
|
||||||
|
pattern UnionBaseType :: forall m. UnionType m -> Type m
|
||||||
|
pattern UnionBaseType unionType <- (isUnionType -> Just unionType)
|
||||||
|
|
||||||
|
-- | Matches either 'ListType' or 'NonNullListType'.
|
||||||
|
pattern ListBaseType :: forall m. Type m -> Type m
|
||||||
|
pattern ListBaseType listType <- (isListType -> Just listType)
|
||||||
|
|
||||||
|
{-# COMPLETE ScalarBaseType
|
||||||
|
, EnumBaseType
|
||||||
|
, ObjectBaseType
|
||||||
|
, ListBaseType
|
||||||
|
, InterfaceBaseType
|
||||||
|
, UnionBaseType
|
||||||
|
#-}
|
||||||
|
|
||||||
|
isScalarType :: forall m. Type m -> Maybe ScalarType
|
||||||
|
isScalarType (NamedScalarType outputType) = Just outputType
|
||||||
|
isScalarType (NonNullScalarType outputType) = Just outputType
|
||||||
|
isScalarType _ = Nothing
|
||||||
|
|
||||||
|
isObjectType :: forall m. Type m -> Maybe (ObjectType m)
|
||||||
|
isObjectType (NamedObjectType outputType) = Just outputType
|
||||||
|
isObjectType (NonNullObjectType outputType) = Just outputType
|
||||||
|
isObjectType _ = Nothing
|
||||||
|
|
||||||
|
isEnumType :: forall m. Type m -> Maybe EnumType
|
||||||
|
isEnumType (NamedEnumType outputType) = Just outputType
|
||||||
|
isEnumType (NonNullEnumType outputType) = Just outputType
|
||||||
|
isEnumType _ = Nothing
|
||||||
|
|
||||||
|
isInterfaceType :: forall m. Type m -> Maybe (InterfaceType m)
|
||||||
|
isInterfaceType (NamedInterfaceType interfaceType) = Just interfaceType
|
||||||
|
isInterfaceType (NonNullInterfaceType interfaceType) = Just interfaceType
|
||||||
|
isInterfaceType _ = Nothing
|
||||||
|
|
||||||
|
isUnionType :: forall m. Type m -> Maybe (UnionType m)
|
||||||
|
isUnionType (NamedUnionType unionType) = Just unionType
|
||||||
|
isUnionType (NonNullUnionType unionType) = Just unionType
|
||||||
|
isUnionType _ = Nothing
|
||||||
|
|
||||||
|
isListType :: forall m. Type m -> Maybe (Type m)
|
||||||
|
isListType (ListType outputType) = Just outputType
|
||||||
|
isListType (NonNullListType outputType) = Just outputType
|
||||||
|
isListType _ = Nothing
|
||||||
|
|
||||||
|
-- | Checks whether the given output type is a non-null type.
|
||||||
|
isNonNullType :: forall m. Type m -> Bool
|
||||||
|
isNonNullType (NonNullScalarType _) = True
|
||||||
|
isNonNullType (NonNullEnumType _) = True
|
||||||
|
isNonNullType (NonNullObjectType _) = True
|
||||||
|
isNonNullType (NonNullInterfaceType _) = True
|
||||||
|
isNonNullType (NonNullUnionType _) = True
|
||||||
|
isNonNullType (NonNullListType _) = True
|
||||||
|
isNonNullType _ = False
|
|
@ -0,0 +1,112 @@
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
|
||||||
|
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||||
|
-- functions for defining and manipulating schemas.
|
||||||
|
module Language.GraphQL.Type.Schema
|
||||||
|
( AbstractType(..)
|
||||||
|
, CompositeType(..)
|
||||||
|
, Schema(..)
|
||||||
|
, Type(..)
|
||||||
|
, collectReferencedTypes
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Language.GraphQL.AST.Document (Name)
|
||||||
|
import qualified Language.GraphQL.Type.Definition as Definition
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
|
||||||
|
-- | These are all of the possible kinds of types.
|
||||||
|
data Type m
|
||||||
|
= ScalarType Definition.ScalarType
|
||||||
|
| EnumType Definition.EnumType
|
||||||
|
| ObjectType (Out.ObjectType m)
|
||||||
|
| InputObjectType In.InputObjectType
|
||||||
|
| InterfaceType (Out.InterfaceType m)
|
||||||
|
| UnionType (Out.UnionType m)
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
|
-- | These types may describe the parent context of a selection set.
|
||||||
|
data CompositeType m
|
||||||
|
= CompositeUnionType (Out.UnionType m)
|
||||||
|
| CompositeObjectType (Out.ObjectType m)
|
||||||
|
| CompositeInterfaceType (Out.InterfaceType m)
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
|
-- | These types may describe the parent context of a selection set.
|
||||||
|
data AbstractType m
|
||||||
|
= AbstractUnionType (Out.UnionType m)
|
||||||
|
| AbstractInterfaceType (Out.InterfaceType m)
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
|
-- | A Schema is created by supplying the root types of each type of operation,
|
||||||
|
-- query and mutation (optional). A schema definition is then supplied to the
|
||||||
|
-- validator and executor.
|
||||||
|
--
|
||||||
|
-- __Note:__ When the schema is constructed, by default only the types that
|
||||||
|
-- are reachable by traversing the root types are included, other types must
|
||||||
|
-- be explicitly referenced.
|
||||||
|
data Schema m = Schema
|
||||||
|
{ query :: Out.ObjectType m
|
||||||
|
, mutation :: Maybe (Out.ObjectType m)
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | Traverses the schema and finds all referenced types.
|
||||||
|
collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
|
||||||
|
collectReferencedTypes schema =
|
||||||
|
let queryTypes = traverseObjectType (query schema) HashMap.empty
|
||||||
|
in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
|
||||||
|
where
|
||||||
|
collect traverser typeName element foundTypes
|
||||||
|
| HashMap.member typeName foundTypes = foundTypes
|
||||||
|
| otherwise = traverser $ HashMap.insert typeName element foundTypes
|
||||||
|
visitFields (Out.Field _ outputType arguments) foundTypes
|
||||||
|
= traverseOutputType outputType
|
||||||
|
$ foldr visitArguments foundTypes arguments
|
||||||
|
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
|
||||||
|
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
|
||||||
|
traverseInputType (In.InputObjectBaseType objectType) =
|
||||||
|
let (In.InputObjectType typeName _ inputFields) = objectType
|
||||||
|
element = InputObjectType objectType
|
||||||
|
traverser = flip (foldr visitInputFields) inputFields
|
||||||
|
in collect traverser typeName element
|
||||||
|
traverseInputType (In.ListBaseType listType) =
|
||||||
|
traverseInputType listType
|
||||||
|
traverseInputType (In.ScalarBaseType scalarType) =
|
||||||
|
let (Definition.ScalarType typeName _) = scalarType
|
||||||
|
in collect Prelude.id typeName (ScalarType scalarType)
|
||||||
|
traverseInputType (In.EnumBaseType enumType) =
|
||||||
|
let (Definition.EnumType typeName _ _) = enumType
|
||||||
|
in collect Prelude.id typeName (EnumType enumType)
|
||||||
|
traverseOutputType (Out.ObjectBaseType objectType) =
|
||||||
|
traverseObjectType objectType
|
||||||
|
traverseOutputType (Out.InterfaceBaseType interfaceType) =
|
||||||
|
traverseInterfaceType interfaceType
|
||||||
|
traverseOutputType (Out.UnionBaseType unionType) =
|
||||||
|
let (Out.UnionType typeName _ types) = unionType
|
||||||
|
traverser = flip (foldr traverseObjectType) types
|
||||||
|
in collect traverser typeName (UnionType unionType)
|
||||||
|
traverseOutputType (Out.ListBaseType listType) =
|
||||||
|
traverseOutputType listType
|
||||||
|
traverseOutputType (Out.ScalarBaseType scalarType) =
|
||||||
|
let (Definition.ScalarType typeName _) = scalarType
|
||||||
|
in collect Prelude.id typeName (ScalarType scalarType)
|
||||||
|
traverseOutputType (Out.EnumBaseType enumType) =
|
||||||
|
let (Definition.EnumType typeName _ _) = enumType
|
||||||
|
in collect Prelude.id typeName (EnumType enumType)
|
||||||
|
traverseObjectType objectType foundTypes =
|
||||||
|
let (Out.ObjectType typeName _ interfaces resolvers) = objectType
|
||||||
|
element = ObjectType objectType
|
||||||
|
fields = extractObjectField <$> resolvers
|
||||||
|
traverser = polymorphicTraverser interfaces fields
|
||||||
|
in collect traverser typeName element foundTypes
|
||||||
|
traverseInterfaceType interfaceType foundTypes =
|
||||||
|
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
|
||||||
|
element = InterfaceType interfaceType
|
||||||
|
traverser = polymorphicTraverser interfaces fields
|
||||||
|
in collect traverser typeName element foundTypes
|
||||||
|
polymorphicTraverser interfaces fields
|
||||||
|
= flip (foldr visitFields) fields
|
||||||
|
. flip (foldr traverseInterfaceType) interfaces
|
||||||
|
extractObjectField (Out.Resolver field _) = field
|
|
@ -1,4 +1,4 @@
|
||||||
resolver: lts-15.12
|
resolver: lts-16.1
|
||||||
|
|
||||||
packages:
|
packages:
|
||||||
- .
|
- .
|
||||||
|
|
|
@ -8,7 +8,7 @@ import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import Language.GraphQL.AST.Document
|
import Language.GraphQL.AST.Document
|
||||||
import Language.GraphQL.AST.Parser
|
import Language.GraphQL.AST.Parser
|
||||||
import Test.Hspec (Spec, describe, it)
|
import Test.Hspec (Spec, describe, it)
|
||||||
import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
|
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
|
||||||
import Text.Megaparsec (parse)
|
import Text.Megaparsec (parse)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
|
@ -141,4 +141,11 @@ spec = describe "Parser" $ do
|
||||||
extend type Story {
|
extend type Story {
|
||||||
isHiddenLocally: Boolean
|
isHiddenLocally: Boolean
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
it "rejects variables in DefaultValue" $
|
||||||
|
parse document "" `shouldFailOn` [r|
|
||||||
|
query ($book: String = "Zarathustra", $author: String = $book) {
|
||||||
|
title
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
|
|
@ -0,0 +1,122 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
module Language.GraphQL.Execute.CoerceSpec
|
||||||
|
( spec
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Aeson as Aeson ((.=))
|
||||||
|
import qualified Data.Aeson as Aeson
|
||||||
|
import qualified Data.Aeson.Types as Aeson
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Data.Maybe (isNothing)
|
||||||
|
import Data.Scientific (scientific)
|
||||||
|
import qualified Language.GraphQL.Execute.Coerce as Coerce
|
||||||
|
import Language.GraphQL.Type
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
import Prelude hiding (id)
|
||||||
|
import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
|
||||||
|
|
||||||
|
direction :: EnumType
|
||||||
|
direction = EnumType "Direction" Nothing $ HashMap.fromList
|
||||||
|
[ ("NORTH", EnumValue Nothing)
|
||||||
|
, ("EAST", EnumValue Nothing)
|
||||||
|
, ("SOUTH", EnumValue Nothing)
|
||||||
|
, ("WEST", EnumValue Nothing)
|
||||||
|
]
|
||||||
|
|
||||||
|
singletonInputObject :: In.Type
|
||||||
|
singletonInputObject = In.NamedInputObjectType type'
|
||||||
|
where
|
||||||
|
type' = In.InputObjectType "ObjectName" Nothing inputFields
|
||||||
|
inputFields = HashMap.singleton "field" field
|
||||||
|
field = In.InputField Nothing (In.NamedScalarType string) Nothing
|
||||||
|
|
||||||
|
namedIdType :: In.Type
|
||||||
|
namedIdType = In.NamedScalarType id
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "VariableValue Aeson" $ do
|
||||||
|
it "coerces strings" $
|
||||||
|
let expected = Just (String "asdf")
|
||||||
|
actual = Coerce.coerceVariableValue
|
||||||
|
(In.NamedScalarType string) (Aeson.String "asdf")
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "coerces non-null strings" $
|
||||||
|
let expected = Just (String "asdf")
|
||||||
|
actual = Coerce.coerceVariableValue
|
||||||
|
(In.NonNullScalarType string) (Aeson.String "asdf")
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "coerces booleans" $
|
||||||
|
let expected = Just (Boolean True)
|
||||||
|
actual = Coerce.coerceVariableValue
|
||||||
|
(In.NamedScalarType boolean) (Aeson.Bool True)
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "coerces zero to an integer" $
|
||||||
|
let expected = Just (Int 0)
|
||||||
|
actual = Coerce.coerceVariableValue
|
||||||
|
(In.NamedScalarType int) (Aeson.Number 0)
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "rejects fractional if an integer is expected" $
|
||||||
|
let actual = Coerce.coerceVariableValue
|
||||||
|
(In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1))
|
||||||
|
in actual `shouldSatisfy` isNothing
|
||||||
|
it "coerces float numbers" $
|
||||||
|
let expected = Just (Float 1.4)
|
||||||
|
actual = Coerce.coerceVariableValue
|
||||||
|
(In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1))
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "coerces IDs" $
|
||||||
|
let expected = Just (String "1234")
|
||||||
|
json = Aeson.String "1234"
|
||||||
|
actual = Coerce.coerceVariableValue namedIdType json
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "coerces input objects" $
|
||||||
|
let actual = Coerce.coerceVariableValue singletonInputObject
|
||||||
|
$ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]
|
||||||
|
expected = Just $ Object $ HashMap.singleton "field" "asdf"
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "skips the field if it is missing in the variables" $
|
||||||
|
let actual = Coerce.coerceVariableValue
|
||||||
|
singletonInputObject Aeson.emptyObject
|
||||||
|
expected = Just $ Object HashMap.empty
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "fails if input object value contains extra fields" $
|
||||||
|
let actual = Coerce.coerceVariableValue singletonInputObject
|
||||||
|
$ Aeson.object variableFields
|
||||||
|
variableFields =
|
||||||
|
[ "field" .= ("asdf" :: Aeson.Value)
|
||||||
|
, "extra" .= ("qwer" :: Aeson.Value)
|
||||||
|
]
|
||||||
|
in actual `shouldSatisfy` isNothing
|
||||||
|
it "preserves null" $
|
||||||
|
let actual = Coerce.coerceVariableValue namedIdType Aeson.Null
|
||||||
|
in actual `shouldBe` Just Null
|
||||||
|
it "preserves list order" $
|
||||||
|
let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
|
||||||
|
listType = (In.ListType $ In.NamedScalarType string)
|
||||||
|
actual = Coerce.coerceVariableValue listType list
|
||||||
|
expected = Just $ List [String "asdf", String "qwer"]
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
|
||||||
|
describe "coerceInputLiteral" $ do
|
||||||
|
it "coerces enums" $
|
||||||
|
let expected = Just (Enum "NORTH")
|
||||||
|
actual = Coerce.coerceInputLiteral
|
||||||
|
(In.NamedEnumType direction) (Enum "NORTH")
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "fails with non-existing enum value" $
|
||||||
|
let actual = Coerce.coerceInputLiteral
|
||||||
|
(In.NamedEnumType direction) (Enum "NORTH_EAST")
|
||||||
|
in actual `shouldSatisfy` isNothing
|
||||||
|
it "coerces integers to IDs" $
|
||||||
|
let expected = Just (String "1234")
|
||||||
|
actual = Coerce.coerceInputLiteral namedIdType (Int 1234)
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "coerces nulls" $ do
|
||||||
|
let actual = Coerce.coerceInputLiteral namedIdType Null
|
||||||
|
in actual `shouldBe` Just Null
|
||||||
|
it "wraps singleton lists" $ do
|
||||||
|
let expected = Just $ List [List [String "1"]]
|
||||||
|
embeddedType = In.ListType $ In.ListType namedIdType
|
||||||
|
actual = Coerce.coerceInputLiteral embeddedType (String "1")
|
||||||
|
in actual `shouldBe` expected
|
|
@ -0,0 +1,75 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
module Language.GraphQL.ExecuteSpec
|
||||||
|
( spec
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Aeson ((.=))
|
||||||
|
import qualified Data.Aeson as Aeson
|
||||||
|
import Data.Functor.Identity (Identity(..))
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Language.GraphQL.AST (Name)
|
||||||
|
import Language.GraphQL.AST.Parser (document)
|
||||||
|
import Language.GraphQL.Error
|
||||||
|
import Language.GraphQL.Execute
|
||||||
|
import Language.GraphQL.Type as Type
|
||||||
|
import Language.GraphQL.Type.Out as Out
|
||||||
|
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||||
|
import Text.Megaparsec (parse)
|
||||||
|
|
||||||
|
schema :: Schema Identity
|
||||||
|
schema = Schema {query = queryType, mutation = Nothing}
|
||||||
|
|
||||||
|
queryType :: Out.ObjectType Identity
|
||||||
|
queryType = Out.ObjectType "Query" Nothing []
|
||||||
|
$ HashMap.singleton "philosopher"
|
||||||
|
$ Out.Resolver philosopherField
|
||||||
|
$ pure
|
||||||
|
$ Type.Object mempty
|
||||||
|
where
|
||||||
|
philosopherField =
|
||||||
|
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
|
||||||
|
|
||||||
|
philosopherType :: Out.ObjectType Identity
|
||||||
|
philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||||
|
$ HashMap.fromList resolvers
|
||||||
|
where
|
||||||
|
resolvers =
|
||||||
|
[ ("firstName", firstNameResolver)
|
||||||
|
, ("lastName", lastNameResolver)
|
||||||
|
]
|
||||||
|
firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich"
|
||||||
|
lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche"
|
||||||
|
firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "execute" $ do
|
||||||
|
it "skips unknown fields" $
|
||||||
|
let expected = Aeson.object
|
||||||
|
[ "data" .= Aeson.object
|
||||||
|
[ "philosopher" .= Aeson.object
|
||||||
|
[ "firstName" .= ("Friedrich" :: String)
|
||||||
|
]
|
||||||
|
]
|
||||||
|
]
|
||||||
|
execute' = execute schema (mempty :: HashMap Name Aeson.Value)
|
||||||
|
actual = runIdentity
|
||||||
|
$ either parseError execute'
|
||||||
|
$ parse document "" "{ philosopher { firstName surname } }"
|
||||||
|
in actual `shouldBe` expected
|
||||||
|
it "merges selections" $
|
||||||
|
let expected = Aeson.object
|
||||||
|
[ "data" .= Aeson.object
|
||||||
|
[ "philosopher" .= Aeson.object
|
||||||
|
[ "firstName" .= ("Friedrich" :: String)
|
||||||
|
, "lastName" .= ("Nietzsche" :: String)
|
||||||
|
]
|
||||||
|
]
|
||||||
|
]
|
||||||
|
execute' = execute schema (mempty :: HashMap Name Aeson.Value)
|
||||||
|
actual = runIdentity
|
||||||
|
$ either parseError execute'
|
||||||
|
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||||
|
in actual `shouldBe` expected
|
|
@ -0,0 +1,14 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
module Language.GraphQL.Type.OutSpec
|
||||||
|
( spec
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Language.GraphQL.Type
|
||||||
|
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "Value" $
|
||||||
|
it "supports overloaded strings" $
|
||||||
|
let nietzsche = "Goldstaub abblasen." :: Value
|
||||||
|
in nietzsche `shouldBe` String "Goldstaub abblasen."
|
|
@ -4,21 +4,24 @@ module Test.DirectiveSpec
|
||||||
( spec
|
( spec
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Aeson (Value, object, (.=))
|
import Data.Aeson (object, (.=))
|
||||||
import Data.HashMap.Strict (HashMap)
|
import qualified Data.Aeson as Aeson
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Language.GraphQL
|
import Language.GraphQL
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
import Language.GraphQL.Type
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
experimentalResolver :: Schema IO
|
||||||
experimentalResolver = HashMap.singleton "Query"
|
experimentalResolver = Schema { query = queryType, mutation = Nothing }
|
||||||
$ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
|
where
|
||||||
|
resolver = pure $ Int 5
|
||||||
|
queryType = Out.ObjectType "Query" Nothing []
|
||||||
|
$ HashMap.singleton "experimentalField"
|
||||||
|
$ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) resolver
|
||||||
|
|
||||||
emptyObject :: Value
|
emptyObject :: Aeson.Value
|
||||||
emptyObject = object
|
emptyObject = object
|
||||||
[ "data" .= object []
|
[ "data" .= object []
|
||||||
]
|
]
|
||||||
|
@ -27,17 +30,17 @@ spec :: Spec
|
||||||
spec =
|
spec =
|
||||||
describe "Directive executor" $ do
|
describe "Directive executor" $ do
|
||||||
it "should be able to @skip fields" $ do
|
it "should be able to @skip fields" $ do
|
||||||
let query = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
experimentalField @skip(if: true)
|
experimentalField @skip(if: true)
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql experimentalResolver query
|
actual <- graphql experimentalResolver sourceQuery
|
||||||
actual `shouldBe` emptyObject
|
actual `shouldBe` emptyObject
|
||||||
|
|
||||||
it "should not skip fields if @skip is false" $ do
|
it "should not skip fields if @skip is false" $ do
|
||||||
let query = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
experimentalField @skip(if: false)
|
experimentalField @skip(if: false)
|
||||||
}
|
}
|
||||||
|
@ -48,21 +51,21 @@ spec =
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
actual <- graphql experimentalResolver query
|
actual <- graphql experimentalResolver sourceQuery
|
||||||
actual `shouldBe` expected
|
actual `shouldBe` expected
|
||||||
|
|
||||||
it "should skip fields if @include is false" $ do
|
it "should skip fields if @include is false" $ do
|
||||||
let query = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
experimentalField @include(if: false)
|
experimentalField @include(if: false)
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql experimentalResolver query
|
actual <- graphql experimentalResolver sourceQuery
|
||||||
actual `shouldBe` emptyObject
|
actual `shouldBe` emptyObject
|
||||||
|
|
||||||
it "should be able to @skip a fragment spread" $ do
|
it "should be able to @skip a fragment spread" $ do
|
||||||
let query = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
...experimentalFragment @skip(if: true)
|
...experimentalFragment @skip(if: true)
|
||||||
}
|
}
|
||||||
|
@ -72,11 +75,11 @@ spec =
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql experimentalResolver query
|
actual <- graphql experimentalResolver sourceQuery
|
||||||
actual `shouldBe` emptyObject
|
actual `shouldBe` emptyObject
|
||||||
|
|
||||||
it "should be able to @skip an inline fragment" $ do
|
it "should be able to @skip an inline fragment" $ do
|
||||||
let query = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
... on ExperimentalType @skip(if: true) {
|
... on ExperimentalType @skip(if: true) {
|
||||||
experimentalField
|
experimentalField
|
||||||
|
@ -84,5 +87,5 @@ spec =
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql experimentalResolver query
|
actual <- graphql experimentalResolver sourceQuery
|
||||||
actual `shouldBe` emptyObject
|
actual `shouldBe` emptyObject
|
||||||
|
|
|
@ -4,32 +4,35 @@ module Test.FragmentSpec
|
||||||
( spec
|
( spec
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Aeson (Value(..), object, (.=))
|
import Data.Aeson (object, (.=))
|
||||||
|
import qualified Data.Aeson as Aeson
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Language.GraphQL
|
import Language.GraphQL
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
import Language.GraphQL.Type
|
||||||
import Test.Hspec ( Spec
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
, describe
|
import Test.Hspec
|
||||||
, it
|
( Spec
|
||||||
, shouldBe
|
, describe
|
||||||
, shouldSatisfy
|
, it
|
||||||
, shouldNotSatisfy
|
, shouldBe
|
||||||
)
|
, shouldNotSatisfy
|
||||||
|
)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
size :: Schema.Resolver IO
|
size :: (Text, Value)
|
||||||
size = Schema.scalar "size" $ return ("L" :: Text)
|
size = ("size", String "L")
|
||||||
|
|
||||||
circumference :: Schema.Resolver IO
|
circumference :: (Text, Value)
|
||||||
circumference = Schema.scalar "circumference" $ return (60 :: Int)
|
circumference = ("circumference", Int 60)
|
||||||
|
|
||||||
garment :: Text -> Schema.Resolver IO
|
garment :: Text -> (Text, Value)
|
||||||
garment typeName = Schema.object "garment" $ return
|
garment typeName =
|
||||||
[ if typeName == "Hat" then circumference else size
|
("garment", Object $ HashMap.fromList
|
||||||
, Schema.scalar "__typename" $ return typeName
|
[ if typeName == "Hat" then circumference else size
|
||||||
]
|
, ("__typename", String typeName)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
|
||||||
inlineQuery :: Text
|
inlineQuery :: Text
|
||||||
inlineQuery = [r|{
|
inlineQuery = [r|{
|
||||||
|
@ -43,15 +46,52 @@ inlineQuery = [r|{
|
||||||
}
|
}
|
||||||
}|]
|
}|]
|
||||||
|
|
||||||
hasErrors :: Value -> Bool
|
hasErrors :: Aeson.Value -> Bool
|
||||||
hasErrors (Object object') = HashMap.member "errors" object'
|
hasErrors (Aeson.Object object') = HashMap.member "errors" object'
|
||||||
hasErrors _ = True
|
hasErrors _ = True
|
||||||
|
|
||||||
|
shirtType :: Out.ObjectType IO
|
||||||
|
shirtType = Out.ObjectType "Shirt" Nothing []
|
||||||
|
$ HashMap.fromList
|
||||||
|
[ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
|
||||||
|
, ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
|
||||||
|
]
|
||||||
|
|
||||||
|
hatType :: Out.ObjectType IO
|
||||||
|
hatType = Out.ObjectType "Hat" Nothing []
|
||||||
|
$ HashMap.fromList
|
||||||
|
[ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
|
||||||
|
, ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
|
||||||
|
]
|
||||||
|
|
||||||
|
circumferenceFieldType :: Out.Field IO
|
||||||
|
circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
|
||||||
|
|
||||||
|
sizeFieldType :: Out.Field IO
|
||||||
|
sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||||
|
|
||||||
|
toSchema :: Text -> (Text, Value) -> Schema IO
|
||||||
|
toSchema t (_, resolve) = Schema
|
||||||
|
{ query = queryType, mutation = Nothing }
|
||||||
|
where
|
||||||
|
unionMember = if t == "Hat" then hatType else shirtType
|
||||||
|
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||||
|
garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
|
||||||
|
queryType =
|
||||||
|
case t of
|
||||||
|
"circumference" -> hatType
|
||||||
|
"size" -> shirtType
|
||||||
|
_ -> Out.ObjectType "Query" Nothing []
|
||||||
|
$ HashMap.fromList
|
||||||
|
[ ("garment", Out.Resolver garmentField $ pure resolve)
|
||||||
|
, ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")
|
||||||
|
]
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
describe "Inline fragment executor" $ do
|
describe "Inline fragment executor" $ do
|
||||||
it "chooses the first selection if the type matches" $ do
|
it "chooses the first selection if the type matches" $ do
|
||||||
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery
|
actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
|
||||||
let expected = object
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "garment" .= object
|
[ "garment" .= object
|
||||||
|
@ -62,7 +102,7 @@ spec = do
|
||||||
in actual `shouldBe` expected
|
in actual `shouldBe` expected
|
||||||
|
|
||||||
it "chooses the last selection if the type matches" $ do
|
it "chooses the last selection if the type matches" $ do
|
||||||
actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery
|
actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
|
||||||
let expected = object
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "garment" .= object
|
[ "garment" .= object
|
||||||
|
@ -73,7 +113,7 @@ spec = do
|
||||||
in actual `shouldBe` expected
|
in actual `shouldBe` expected
|
||||||
|
|
||||||
it "embeds inline fragments without type" $ do
|
it "embeds inline fragments without type" $ do
|
||||||
let query = [r|{
|
let sourceQuery = [r|{
|
||||||
garment {
|
garment {
|
||||||
circumference
|
circumference
|
||||||
... {
|
... {
|
||||||
|
@ -81,9 +121,9 @@ spec = do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}|]
|
}|]
|
||||||
resolvers = Schema.object "garment" $ return [circumference, size]
|
resolvers = ("garment", Object $ HashMap.fromList [circumference, size])
|
||||||
|
|
||||||
actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query
|
actual <- graphql (toSchema "garment" resolvers) sourceQuery
|
||||||
let expected = object
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "garment" .= object
|
[ "garment" .= object
|
||||||
|
@ -95,18 +135,18 @@ spec = do
|
||||||
in actual `shouldBe` expected
|
in actual `shouldBe` expected
|
||||||
|
|
||||||
it "evaluates fragments on Query" $ do
|
it "evaluates fragments on Query" $ do
|
||||||
let query = [r|{
|
let sourceQuery = [r|{
|
||||||
... {
|
... {
|
||||||
size
|
size
|
||||||
}
|
}
|
||||||
}|]
|
}|]
|
||||||
|
|
||||||
actual <- graphql (HashMap.singleton "Query" $ size :| []) query
|
actual <- graphql (toSchema "size" size) sourceQuery
|
||||||
actual `shouldNotSatisfy` hasErrors
|
actual `shouldNotSatisfy` hasErrors
|
||||||
|
|
||||||
describe "Fragment spread executor" $ do
|
describe "Fragment spread executor" $ do
|
||||||
it "evaluates fragment spreads" $ do
|
it "evaluates fragment spreads" $ do
|
||||||
let query = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
...circumferenceFragment
|
...circumferenceFragment
|
||||||
}
|
}
|
||||||
|
@ -116,7 +156,7 @@ spec = do
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
|
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||||
let expected = object
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "circumference" .= (60 :: Int)
|
[ "circumference" .= (60 :: Int)
|
||||||
|
@ -125,7 +165,7 @@ spec = do
|
||||||
in actual `shouldBe` expected
|
in actual `shouldBe` expected
|
||||||
|
|
||||||
it "evaluates nested fragments" $ do
|
it "evaluates nested fragments" $ do
|
||||||
let query = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
garment {
|
garment {
|
||||||
...circumferenceFragment
|
...circumferenceFragment
|
||||||
|
@ -141,7 +181,7 @@ spec = do
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
|
actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
|
||||||
let expected = object
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "garment" .= object
|
[ "garment" .= object
|
||||||
|
@ -152,7 +192,10 @@ spec = do
|
||||||
in actual `shouldBe` expected
|
in actual `shouldBe` expected
|
||||||
|
|
||||||
it "rejects recursive fragments" $ do
|
it "rejects recursive fragments" $ do
|
||||||
let query = [r|
|
let expected = object
|
||||||
|
[ "data" .= object []
|
||||||
|
]
|
||||||
|
sourceQuery = [r|
|
||||||
{
|
{
|
||||||
...circumferenceFragment
|
...circumferenceFragment
|
||||||
}
|
}
|
||||||
|
@ -162,11 +205,11 @@ spec = do
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
|
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||||
actual `shouldSatisfy` hasErrors
|
actual `shouldBe` expected
|
||||||
|
|
||||||
it "considers type condition" $ do
|
it "considers type condition" $ do
|
||||||
let query = [r|
|
let sourceQuery = [r|
|
||||||
{
|
{
|
||||||
garment {
|
garment {
|
||||||
...circumferenceFragment
|
...circumferenceFragment
|
||||||
|
@ -187,5 +230,5 @@ spec = do
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
|
actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
|
||||||
actual `shouldBe` expected
|
actual `shouldBe` expected
|
||||||
|
|
|
@ -0,0 +1,68 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
module Test.RootOperationSpec
|
||||||
|
( spec
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Aeson ((.=), object)
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Language.GraphQL
|
||||||
|
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||||
|
import Text.RawString.QQ (r)
|
||||||
|
import Language.GraphQL.Type
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
|
|
||||||
|
hatType :: Out.ObjectType IO
|
||||||
|
hatType = Out.ObjectType "Hat" Nothing []
|
||||||
|
$ HashMap.singleton "circumference"
|
||||||
|
$ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||||
|
$ pure $ Int 60
|
||||||
|
|
||||||
|
schema :: Schema IO
|
||||||
|
schema = Schema
|
||||||
|
(Out.ObjectType "Query" Nothing [] hatField)
|
||||||
|
(Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
|
||||||
|
where
|
||||||
|
garment = pure $ Object $ HashMap.fromList
|
||||||
|
[ ("circumference", Int 60)
|
||||||
|
]
|
||||||
|
incrementField = HashMap.singleton "incrementCircumference"
|
||||||
|
$ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||||
|
$ pure $ Int 61
|
||||||
|
hatField = HashMap.singleton "garment"
|
||||||
|
$ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment
|
||||||
|
|
||||||
|
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
|
|
@ -11,7 +11,7 @@ module Test.StarWars.Data
|
||||||
, getHuman
|
, getHuman
|
||||||
, id_
|
, id_
|
||||||
, homePlanet
|
, homePlanet
|
||||||
, name
|
, name_
|
||||||
, secretBackstory
|
, secretBackstory
|
||||||
, typeName
|
, typeName
|
||||||
) where
|
) where
|
||||||
|
@ -22,7 +22,6 @@ import Control.Monad.Trans.Except (throwE)
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Language.GraphQL.Trans
|
import Language.GraphQL.Trans
|
||||||
import qualified Language.GraphQL.Type as Type
|
|
||||||
|
|
||||||
-- * Data
|
-- * Data
|
||||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
|
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
|
||||||
|
@ -55,9 +54,9 @@ id_ :: Character -> ID
|
||||||
id_ (Left x) = _id_ . _droidChar $ x
|
id_ (Left x) = _id_ . _droidChar $ x
|
||||||
id_ (Right x) = _id_ . _humanChar $ x
|
id_ (Right x) = _id_ . _humanChar $ x
|
||||||
|
|
||||||
name :: Character -> Text
|
name_ :: Character -> Text
|
||||||
name (Left x) = _name . _droidChar $ x
|
name_ (Left x) = _name . _droidChar $ x
|
||||||
name (Right x) = _name . _humanChar $ x
|
name_ (Right x) = _name . _humanChar $ x
|
||||||
|
|
||||||
friends :: Character -> [ID]
|
friends :: Character -> [ID]
|
||||||
friends (Left x) = _friends . _droidChar $ x
|
friends (Left x) = _friends . _droidChar $ x
|
||||||
|
@ -67,8 +66,8 @@ appearsIn :: Character -> [Int]
|
||||||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
||||||
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
||||||
|
|
||||||
secretBackstory :: Character -> ActionT Identity Text
|
secretBackstory :: ActionT Identity Text
|
||||||
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
|
secretBackstory = ActionT $ throwE "secretBackstory is secret."
|
||||||
|
|
||||||
typeName :: Character -> Text
|
typeName :: Character -> Text
|
||||||
typeName = either (const "Droid") (const "Human")
|
typeName = either (const "Droid") (const "Human")
|
||||||
|
@ -184,8 +183,8 @@ getDroid' _ = empty
|
||||||
getFriends :: Character -> [Character]
|
getFriends :: Character -> [Character]
|
||||||
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
|
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
|
||||||
|
|
||||||
getEpisode :: Int -> Maybe (Type.Wrapping Text)
|
getEpisode :: Int -> Maybe Text
|
||||||
getEpisode 4 = pure $ Type.Named "NEWHOPE"
|
getEpisode 4 = pure "NEW_HOPE"
|
||||||
getEpisode 5 = pure $ Type.Named "EMPIRE"
|
getEpisode 5 = pure "EMPIRE"
|
||||||
getEpisode 6 = pure $ Type.Named "JEDI"
|
getEpisode 6 = pure "JEDI"
|
||||||
getEpisode _ = empty
|
getEpisode _ = empty
|
||||||
|
|
|
@ -10,7 +10,6 @@ import Data.Functor.Identity (Identity(..))
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Language.GraphQL
|
import Language.GraphQL
|
||||||
import Language.GraphQL.Schema (Subs)
|
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
import Test.Hspec.Expectations (Expectation, shouldBe)
|
import Test.Hspec.Expectations (Expectation, shouldBe)
|
||||||
import Test.Hspec (Spec, describe, it)
|
import Test.Hspec (Spec, describe, it)
|
||||||
|
@ -40,7 +39,7 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
id
|
id
|
||||||
name
|
name
|
||||||
friends {
|
friends {
|
||||||
name
|
name
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -65,9 +64,9 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
friends {
|
friends {
|
||||||
name
|
name
|
||||||
appearsIn
|
appearsIn
|
||||||
friends {
|
friends {
|
||||||
name
|
name
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -78,7 +77,7 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
, "friends" .= [
|
, "friends" .= [
|
||||||
Aeson.object [
|
Aeson.object [
|
||||||
"name" .= ("Luke Skywalker" :: Text)
|
"name" .= ("Luke Skywalker" :: Text)
|
||||||
, "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
|
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
||||||
, "friends" .= [
|
, "friends" .= [
|
||||||
Aeson.object [hanName]
|
Aeson.object [hanName]
|
||||||
, Aeson.object [leiaName]
|
, Aeson.object [leiaName]
|
||||||
|
@ -88,7 +87,7 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
]
|
]
|
||||||
, Aeson.object [
|
, Aeson.object [
|
||||||
hanName
|
hanName
|
||||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
||||||
, "friends" .=
|
, "friends" .=
|
||||||
[ Aeson.object [lukeName]
|
[ Aeson.object [lukeName]
|
||||||
, Aeson.object [leiaName]
|
, Aeson.object [leiaName]
|
||||||
|
@ -97,7 +96,7 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
]
|
]
|
||||||
, Aeson.object [
|
, Aeson.object [
|
||||||
leiaName
|
leiaName
|
||||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
||||||
, "friends" .=
|
, "friends" .=
|
||||||
[ Aeson.object [lukeName]
|
[ Aeson.object [lukeName]
|
||||||
, Aeson.object [hanName]
|
, Aeson.object [hanName]
|
||||||
|
@ -360,6 +359,6 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
testQuery :: Text -> Aeson.Value -> Expectation
|
testQuery :: Text -> Aeson.Value -> Expectation
|
||||||
testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
|
testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
|
||||||
|
|
||||||
testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation
|
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
|
||||||
testQueryParams f q expected =
|
testQueryParams f q expected =
|
||||||
runIdentity (graphqlSubs schema f q) `shouldBe` expected
|
runIdentity (graphqlSubs schema f q) `shouldBe` expected
|
||||||
|
|
|
@ -1,66 +1,133 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Test.StarWars.Schema
|
module Test.StarWars.Schema
|
||||||
( character
|
( schema
|
||||||
, droid
|
|
||||||
, hero
|
|
||||||
, human
|
|
||||||
, schema
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Reader (asks)
|
||||||
import Control.Monad.Trans.Except (throwE)
|
import Control.Monad.Trans.Except (throwE)
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Monad.Trans.Class (lift)
|
||||||
import Data.Functor.Identity (Identity)
|
import Data.Functor.Identity (Identity)
|
||||||
import Data.HashMap.Strict (HashMap)
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
|
||||||
import Language.GraphQL.Trans
|
import Language.GraphQL.Trans
|
||||||
import qualified Language.GraphQL.Type as Type
|
import Language.GraphQL.Type
|
||||||
|
import qualified Language.GraphQL.Type.In as In
|
||||||
|
import qualified Language.GraphQL.Type.Out as Out
|
||||||
import Test.StarWars.Data
|
import Test.StarWars.Data
|
||||||
|
import Prelude hiding (id)
|
||||||
|
|
||||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
||||||
|
|
||||||
schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
|
schema :: Schema Identity
|
||||||
schema = HashMap.singleton "Query" $ hero :| [human, droid]
|
schema = Schema { query = queryType, mutation = Nothing }
|
||||||
|
where
|
||||||
|
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||||
|
[ ("hero", Out.Resolver heroField hero)
|
||||||
|
, ("human", Out.Resolver humanField human)
|
||||||
|
, ("droid", Out.Resolver droidField droid)
|
||||||
|
]
|
||||||
|
heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
|
||||||
|
$ HashMap.singleton "episode"
|
||||||
|
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
|
||||||
|
humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
|
||||||
|
$ HashMap.singleton "id"
|
||||||
|
$ In.Argument Nothing (In.NonNullScalarType string) Nothing
|
||||||
|
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
|
||||||
|
|
||||||
hero :: Schema.Resolver Identity
|
heroObject :: Out.ObjectType Identity
|
||||||
hero = Schema.object "hero" $ do
|
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
|
||||||
|
[ ("id", Out.Resolver idFieldType (idField "id"))
|
||||||
|
, ("name", Out.Resolver nameFieldType (idField "name"))
|
||||||
|
, ("friends", Out.Resolver friendsFieldType (idField "friends"))
|
||||||
|
, ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
|
||||||
|
, ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
|
||||||
|
, ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
|
||||||
|
, ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
|
||||||
|
]
|
||||||
|
where
|
||||||
|
homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||||
|
|
||||||
|
droidObject :: Out.ObjectType Identity
|
||||||
|
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
|
||||||
|
[ ("id", Out.Resolver idFieldType (idField "id"))
|
||||||
|
, ("name", Out.Resolver nameFieldType (idField "name"))
|
||||||
|
, ("friends", Out.Resolver friendsFieldType (idField "friends"))
|
||||||
|
, ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
|
||||||
|
, ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
|
||||||
|
, ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
|
||||||
|
, ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
|
||||||
|
]
|
||||||
|
where
|
||||||
|
primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||||
|
|
||||||
|
idFieldType :: Out.Field Identity
|
||||||
|
idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
|
||||||
|
|
||||||
|
nameFieldType :: Out.Field Identity
|
||||||
|
nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||||
|
|
||||||
|
friendsFieldType :: Out.Field Identity
|
||||||
|
friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
|
||||||
|
|
||||||
|
appearsInField :: Out.Field Identity
|
||||||
|
appearsInField = Out.Field (Just description) fieldType mempty
|
||||||
|
where
|
||||||
|
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
|
||||||
|
description = "Which movies they appear in."
|
||||||
|
|
||||||
|
secretBackstoryFieldType :: Out.Field Identity
|
||||||
|
secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||||
|
|
||||||
|
idField :: Text -> ActionT Identity Value
|
||||||
|
idField f = do
|
||||||
|
v <- ActionT $ lift $ asks values
|
||||||
|
let (Object v') = v
|
||||||
|
pure $ v' HashMap.! f
|
||||||
|
|
||||||
|
episodeEnum :: EnumType
|
||||||
|
episodeEnum = EnumType "Episode" (Just description)
|
||||||
|
$ HashMap.fromList [newHope, empire, jedi]
|
||||||
|
where
|
||||||
|
description = "One of the films in the Star Wars Trilogy"
|
||||||
|
newHope = ("NEW_HOPE", EnumValue $ Just "Released in 1977.")
|
||||||
|
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
|
||||||
|
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
|
||||||
|
|
||||||
|
hero :: ActionT Identity Value
|
||||||
|
hero = do
|
||||||
episode <- argument "episode"
|
episode <- argument "episode"
|
||||||
character $ case episode of
|
pure $ character $ case episode of
|
||||||
Schema.Enum "NEWHOPE" -> getHero 4
|
Enum "NEW_HOPE" -> getHero 4
|
||||||
Schema.Enum "EMPIRE" -> getHero 5
|
Enum "EMPIRE" -> getHero 5
|
||||||
Schema.Enum "JEDI" -> getHero 6
|
Enum "JEDI" -> getHero 6
|
||||||
_ -> artoo
|
_ -> artoo
|
||||||
|
|
||||||
human :: Schema.Resolver Identity
|
human :: ActionT Identity Value
|
||||||
human = Schema.wrappedObject "human" $ do
|
human = do
|
||||||
id' <- argument "id"
|
id' <- argument "id"
|
||||||
case id' of
|
case id' of
|
||||||
Schema.String i -> do
|
String i -> do
|
||||||
humanCharacter <- lift $ return $ getHuman i >>= Just
|
humanCharacter <- lift $ return $ getHuman i >>= Just
|
||||||
case humanCharacter of
|
case humanCharacter of
|
||||||
Nothing -> return Type.Null
|
Nothing -> pure Null
|
||||||
Just e -> Type.Named <$> character e
|
Just e -> pure $ character e
|
||||||
_ -> ActionT $ throwE "Invalid arguments."
|
_ -> ActionT $ throwE "Invalid arguments."
|
||||||
|
|
||||||
droid :: Schema.Resolver Identity
|
droid :: ActionT Identity Value
|
||||||
droid = Schema.object "droid" $ do
|
droid = do
|
||||||
id' <- argument "id"
|
id' <- argument "id"
|
||||||
case id' of
|
case id' of
|
||||||
Schema.String i -> character =<< getDroid i
|
String i -> character <$> getDroid i
|
||||||
_ -> ActionT $ throwE "Invalid arguments."
|
_ -> ActionT $ throwE "Invalid arguments."
|
||||||
|
|
||||||
character :: Character -> ActionT Identity [Schema.Resolver Identity]
|
character :: Character -> Value
|
||||||
character char = return
|
character char = Object $ HashMap.fromList
|
||||||
[ Schema.scalar "id" $ return $ id_ char
|
[ ("id", String $ id_ char)
|
||||||
, Schema.scalar "name" $ return $ name char
|
, ("name", String $ name_ char)
|
||||||
, Schema.wrappedObject "friends"
|
, ("friends", List $ character <$> getFriends char)
|
||||||
$ traverse character $ Type.List $ Type.Named <$> getFriends char
|
, ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
|
||||||
, Schema.wrappedScalar "appearsIn" $ return . Type.List
|
, ("homePlanet", String $ either mempty homePlanet char)
|
||||||
$ catMaybes (getEpisode <$> appearsIn char)
|
, ("__typename", String $ typeName char)
|
||||||
, Schema.scalar "secretBackstory" $ secretBackstory char
|
|
||||||
, Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
|
|
||||||
, Schema.scalar "__typename" $ return $ typeName char
|
|
||||||
]
|
]
|
||||||
|
|
Loading…
Reference in New Issue