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
|
||||
[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
|
||||
### Fixed
|
||||
|
@ -20,7 +72,7 @@ and this project adheres to
|
|||
- `Trans.argument`.
|
||||
- Schema extension parser.
|
||||
- Contributing guidelines.
|
||||
- `Schema.resolversToMap` (intended for to be used internally).
|
||||
- `Schema.resolversToMap` (intended to be used internally).
|
||||
|
||||
### Changed
|
||||
- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
|
||||
|
@ -215,7 +267,7 @@ and this project adheres to
|
|||
### Added
|
||||
- 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.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
|
||||
|
|
|
@ -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 Data.Aeson (encode)
|
||||
> import Data.ByteString.Lazy.Char8 (putStrLn)
|
||||
> import Data.HashMap.Strict (HashMap)
|
||||
> import qualified Data.HashMap.Strict as HashMap
|
||||
> import Data.List.NonEmpty (NonEmpty(..))
|
||||
> import Data.Text (Text)
|
||||
> import qualified Data.Text as Text
|
||||
> import Data.Time (getCurrentTime)
|
||||
>
|
||||
> 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)
|
||||
|
||||
|
@ -35,11 +36,19 @@ example from [graphql.js](https://github.com/graphql/graphql-js).
|
|||
|
||||
First we build a GraphQL schema.
|
||||
|
||||
> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||
> schema1 = HashMap.singleton "Query" $ hello :| []
|
||||
> schema1 :: Schema IO
|
||||
> schema1 = Schema queryType Nothing
|
||||
>
|
||||
> hello :: Schema.Resolver IO
|
||||
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
|
||||
> queryType :: ObjectType IO
|
||||
> 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.
|
||||
|
||||
|
@ -52,7 +61,7 @@ Next we define our query.
|
|||
To run the query, we call the `graphql` with the schema and the query.
|
||||
|
||||
> main1 :: IO ()
|
||||
> main1 = putStrLn =<< encode <$> graphql schema1 query1
|
||||
> main1 = graphql schema1 query1 >>= putStrLn . encode
|
||||
|
||||
This runs the query by fetching the one field defined,
|
||||
returning
|
||||
|
@ -65,13 +74,21 @@ returning
|
|||
|
||||
For this example, we're going to be using time.
|
||||
|
||||
> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||
> schema2 = HashMap.singleton "Query" $ time :| []
|
||||
> schema2 :: Schema IO
|
||||
> schema2 = Schema queryType2 Nothing
|
||||
>
|
||||
> time :: Schema.Resolver IO
|
||||
> time = Schema.scalar "time" $ do
|
||||
> queryType2 :: ObjectType IO
|
||||
> 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
|
||||
> return $ show t
|
||||
> pure $ String $ Text.pack $ show t
|
||||
|
||||
This defines a simple schema with one type and one field,
|
||||
which resolves to the current time.
|
||||
|
@ -82,7 +99,7 @@ Next we define our query.
|
|||
> query2 = "{ time }"
|
||||
>
|
||||
> main2 :: IO ()
|
||||
> main2 = putStrLn =<< encode <$> graphql schema2 query2
|
||||
> main2 = graphql schema2 query2 >>= putStrLn . encode
|
||||
|
||||
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.
|
||||
|
||||
> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||
> schema3 = HashMap.singleton "Query" $ hello :| [time]
|
||||
> schema3 :: Schema IO
|
||||
> schema3 = Schema queryType3 Nothing
|
||||
>
|
||||
> queryType3 :: ObjectType IO
|
||||
> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
> [ ("hello", Out.Resolver helloField hello)
|
||||
> , ("time", Out.Resolver timeField time)
|
||||
> ]
|
||||
>
|
||||
> query3 :: Text
|
||||
> query3 = "query timeAndHello { time hello }"
|
||||
>
|
||||
> main3 :: IO ()
|
||||
> main3 = putStrLn =<< encode <$> graphql schema3 query3
|
||||
> main3 = graphql schema3 query3 >>= putStrLn . encode
|
||||
|
||||
This queries for both time and hello, returning
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
name: graphql
|
||||
version: 0.7.0.0
|
||||
version: 0.8.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description:
|
||||
This package provides a rudimentary parser for the
|
||||
|
@ -31,15 +31,20 @@ dependencies:
|
|||
- containers
|
||||
- megaparsec
|
||||
- parser-combinators
|
||||
- scientific
|
||||
- text
|
||||
- transformers
|
||||
- unordered-containers
|
||||
- vector
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
other-modules:
|
||||
- Language.GraphQL.Execute.Execution
|
||||
- Language.GraphQL.Execute.Transform
|
||||
- Language.GraphQL.Type.Definition
|
||||
- Language.GraphQL.Type.Directive
|
||||
- Language.GraphQL.Type.Schema
|
||||
|
||||
tests:
|
||||
tasty:
|
||||
|
|
|
@ -5,29 +5,30 @@ module Language.GraphQL
|
|||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Document
|
||||
import Language.GraphQL.AST.Parser
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
import Language.GraphQL.AST.Parser
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Type.Schema
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
-- executed using the given 'Schema.Resolver's.
|
||||
-- executed using the given 'Schema'.
|
||||
graphql :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m Aeson.Value -- ^ Response.
|
||||
graphql = flip graphqlSubs mempty
|
||||
graphql = flip graphqlSubs (mempty :: Aeson.Object)
|
||||
|
||||
-- | 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
|
||||
-- 'Schema.Resolver's.
|
||||
graphqlSubs :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||
-> Schema.Subs -- ^ Variable substitution function.
|
||||
-- 'Schema'.
|
||||
graphqlSubs :: (Monad m, VariableValue a)
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> HashMap Name a -- ^ Variable substitution function.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m Aeson.Value -- ^ Response.
|
||||
graphqlSubs schema f
|
||||
|
|
|
@ -1,41 +1,11 @@
|
|||
-- | This is the AST meant to be executed.
|
||||
module Language.GraphQL.AST.Core
|
||||
( Alias
|
||||
, Arguments(..)
|
||||
, Directive(..)
|
||||
, Document
|
||||
, Field(..)
|
||||
, Fragment(..)
|
||||
, Name
|
||||
, Operation(..)
|
||||
, Selection(..)
|
||||
, TypeCondition
|
||||
, Value(..)
|
||||
( Arguments(..)
|
||||
) where
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Sequence (Seq)
|
||||
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)
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.Type.Definition
|
||||
|
||||
-- | Argument list.
|
||||
newtype Arguments = Arguments (HashMap Name Value)
|
||||
|
@ -47,32 +17,3 @@ instance Semigroup Arguments where
|
|||
instance Monoid Arguments where
|
||||
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
|
||||
, Argument(..)
|
||||
, ArgumentsDefinition(..)
|
||||
, ConstValue(..)
|
||||
, Definition(..)
|
||||
, Description(..)
|
||||
, Directive(..)
|
||||
|
@ -197,7 +198,7 @@ type TypeCondition = Name
|
|||
|
||||
-- ** Input Values
|
||||
|
||||
-- | Input value.
|
||||
-- | Input value (literal or variable).
|
||||
data Value
|
||||
= Variable Name
|
||||
| Int Int32
|
||||
|
@ -207,18 +208,46 @@ data Value
|
|||
| Null
|
||||
| Enum Name
|
||||
| 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)
|
||||
|
||||
-- | Key-value pair.
|
||||
--
|
||||
-- A list of 'ObjectField's represents a GraphQL object type.
|
||||
data ObjectField = ObjectField Name Value deriving (Eq, Show)
|
||||
-- A list of 'ObjectField's represents a GraphQL object type.
|
||||
data ObjectField a = ObjectField Name a
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Variables
|
||||
|
||||
-- | 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)
|
||||
|
||||
-- ** Type References
|
||||
|
@ -445,7 +474,7 @@ instance Monoid ArgumentsDefinition where
|
|||
--
|
||||
-- The input type "Point2D" contains two value definitions: "x" and "y".
|
||||
data InputValueDefinition
|
||||
= InputValueDefinition Description Name Type (Maybe Value) [Directive]
|
||||
= InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Unions
|
||||
|
|
|
@ -24,7 +24,6 @@ import Data.Text.Lazy.Builder (Builder)
|
|||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
|
||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.AST.Document
|
||||
|
||||
-- | 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 _ acc = acc
|
||||
|
||||
-- | Converts a t'Full.ExecutableDefinition' into a string.
|
||||
-- | Converts a t'ExecutableDefinition' into a string.
|
||||
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
|
||||
definition formatter x
|
||||
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
||||
| Minified <- formatter = encodeDefinition x
|
||||
where
|
||||
encodeDefinition (Full.DefinitionOperation operation)
|
||||
encodeDefinition (DefinitionOperation operation)
|
||||
= operationDefinition formatter operation
|
||||
encodeDefinition (Full.DefinitionFragment fragment)
|
||||
encodeDefinition (DefinitionFragment fragment)
|
||||
= fragmentDefinition formatter fragment
|
||||
|
||||
-- | Converts a 'Full.OperationDefinition into a string.
|
||||
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
|
||||
operationDefinition formatter (Full.SelectionSet sels)
|
||||
-- | Converts a 'OperationDefinition into a string.
|
||||
operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
|
||||
operationDefinition formatter (SelectionSet 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
|
||||
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
|
||||
|
||||
-- | Converts a Full.Query or Full.Mutation into a string.
|
||||
-- | Converts a Query or Mutation into a string.
|
||||
node :: Formatter ->
|
||||
Maybe Full.Name ->
|
||||
[Full.VariableDefinition] ->
|
||||
[Full.Directive] ->
|
||||
Full.SelectionSet ->
|
||||
Maybe Name ->
|
||||
[VariableDefinition] ->
|
||||
[Directive] ->
|
||||
SelectionSet ->
|
||||
Lazy.Text
|
||||
node formatter name vars dirs sels
|
||||
= Lazy.Text.fromStrict (fold name)
|
||||
|
@ -87,31 +86,31 @@ node formatter name vars dirs sels
|
|||
<> eitherFormat formatter " " mempty
|
||||
<> selectionSet formatter sels
|
||||
|
||||
variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
|
||||
variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text
|
||||
variableDefinitions formatter
|
||||
= parensCommas formatter $ variableDefinition formatter
|
||||
|
||||
variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
|
||||
variableDefinition formatter (Full.VariableDefinition var ty dv)
|
||||
variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text
|
||||
variableDefinition formatter (VariableDefinition var ty defaultValue')
|
||||
= variable var
|
||||
<> eitherFormat formatter ": " ":"
|
||||
<> 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
|
||||
= eitherFormat formatter " = " "="
|
||||
<> value formatter val
|
||||
<> value formatter (fromConstValue val)
|
||||
|
||||
variable :: Full.Name -> Lazy.Text
|
||||
variable :: Name -> Lazy.Text
|
||||
variable var = "$" <> Lazy.Text.fromStrict var
|
||||
|
||||
selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
|
||||
selectionSet :: Formatter -> SelectionSet -> Lazy.Text
|
||||
selectionSet formatter
|
||||
= bracesList formatter (selection formatter)
|
||||
. NonEmpty.toList
|
||||
|
||||
selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
|
||||
selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text
|
||||
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
||||
|
||||
indentSymbol :: Lazy.Text
|
||||
|
@ -120,14 +119,14 @@ indentSymbol = " "
|
|||
indent :: (Integral a) => a -> Lazy.Text
|
||||
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
|
||||
where
|
||||
encodeSelection (Full.Field alias name args directives' selections) =
|
||||
encodeSelection (Field 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
|
||||
encodeSelection (Full.FragmentSpread name directives') =
|
||||
encodeSelection (FragmentSpread name directives') =
|
||||
fragmentSpread incrementIndent name directives'
|
||||
incrementIndent
|
||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||
|
@ -139,13 +138,13 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
|
|||
colon :: Formatter -> Lazy.Text
|
||||
colon formatter = eitherFormat formatter ": " ":"
|
||||
|
||||
-- | Converts Full.Field into a string
|
||||
-- | Converts Field into a string
|
||||
field :: Formatter ->
|
||||
Maybe Full.Name ->
|
||||
Full.Name ->
|
||||
[Full.Argument] ->
|
||||
[Full.Directive] ->
|
||||
[Full.Selection] ->
|
||||
Maybe Name ->
|
||||
Name ->
|
||||
[Argument] ->
|
||||
[Directive] ->
|
||||
[Selection] ->
|
||||
Lazy.Text
|
||||
field formatter alias name args dirs set
|
||||
= optempty prependAlias (fold alias)
|
||||
|
@ -158,27 +157,27 @@ field formatter alias name args dirs set
|
|||
selectionSetOpt' = (eitherFormat formatter " " "" <>)
|
||||
. selectionSetOpt formatter
|
||||
|
||||
arguments :: Formatter -> [Full.Argument] -> Lazy.Text
|
||||
arguments :: Formatter -> [Argument] -> Lazy.Text
|
||||
arguments formatter = parensCommas formatter $ argument formatter
|
||||
|
||||
argument :: Formatter -> Full.Argument -> Lazy.Text
|
||||
argument formatter (Full.Argument name value')
|
||||
argument :: Formatter -> Argument -> Lazy.Text
|
||||
argument formatter (Argument name value')
|
||||
= Lazy.Text.fromStrict name
|
||||
<> colon formatter
|
||||
<> value formatter value'
|
||||
|
||||
-- * Fragments
|
||||
|
||||
fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text
|
||||
fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
|
||||
fragmentSpread formatter name directives'
|
||||
= "..." <> Lazy.Text.fromStrict name
|
||||
<> optempty (directives formatter) directives'
|
||||
|
||||
inlineFragment ::
|
||||
Formatter ->
|
||||
Maybe Full.TypeCondition ->
|
||||
[Full.Directive] ->
|
||||
Full.SelectionSet ->
|
||||
Maybe TypeCondition ->
|
||||
[Directive] ->
|
||||
SelectionSet ->
|
||||
Lazy.Text
|
||||
inlineFragment formatter tc dirs sels = "... on "
|
||||
<> Lazy.Text.fromStrict (fold tc)
|
||||
|
@ -186,8 +185,8 @@ inlineFragment formatter tc dirs sels = "... on "
|
|||
<> eitherFormat formatter " " mempty
|
||||
<> selectionSet formatter sels
|
||||
|
||||
fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
|
||||
fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
|
||||
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
|
||||
fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
|
||||
= "fragment " <> Lazy.Text.fromStrict name
|
||||
<> " on " <> Lazy.Text.fromStrict tc
|
||||
<> optempty (directives formatter) dirs
|
||||
|
@ -196,26 +195,39 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
|
|||
|
||||
-- * Miscellaneous
|
||||
|
||||
-- | Converts a 'Full.Directive' into a string.
|
||||
directive :: Formatter -> Full.Directive -> Lazy.Text
|
||||
directive formatter (Full.Directive name args)
|
||||
-- | Converts a 'Directive' into a string.
|
||||
directive :: Formatter -> Directive -> Lazy.Text
|
||||
directive formatter (Directive name 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 formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
|
||||
|
||||
-- | Converts a 'Full.Value' into a string.
|
||||
value :: Formatter -> Full.Value -> Lazy.Text
|
||||
value _ (Full.Variable x) = variable x
|
||||
value _ (Full.Int x) = Builder.toLazyText $ decimal x
|
||||
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
|
||||
value _ (Full.Boolean x) = booleanValue x
|
||||
value _ Full.Null = "null"
|
||||
value formatter (Full.String string) = stringValue formatter string
|
||||
value _ (Full.Enum x) = Lazy.Text.fromStrict x
|
||||
value formatter (Full.List x) = listValue formatter x
|
||||
value formatter (Full.Object x) = objectValue formatter x
|
||||
-- | Converts a 'Value' into a string.
|
||||
value :: Formatter -> Value -> Lazy.Text
|
||||
value _ (Variable x) = variable x
|
||||
value _ (Int x) = Builder.toLazyText $ decimal x
|
||||
value _ (Float x) = Builder.toLazyText $ realFloat x
|
||||
value _ (Boolean x) = booleanValue x
|
||||
value _ Null = "null"
|
||||
value formatter (String string) = stringValue formatter string
|
||||
value _ (Enum x) = Lazy.Text.fromStrict x
|
||||
value formatter (List x) = listValue 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 True = "true"
|
||||
|
@ -271,10 +283,10 @@ escape char'
|
|||
where
|
||||
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
|
||||
|
||||
objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text
|
||||
objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text
|
||||
objectValue formatter = intercalate $ objectField formatter
|
||||
where
|
||||
intercalate f
|
||||
|
@ -282,22 +294,22 @@ objectValue formatter = intercalate $ objectField formatter
|
|||
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
|
||||
. fmap f
|
||||
|
||||
objectField :: Formatter -> Full.ObjectField -> Lazy.Text
|
||||
objectField formatter (Full.ObjectField name value') =
|
||||
objectField :: Formatter -> ObjectField Value -> Lazy.Text
|
||||
objectField formatter (ObjectField name value') =
|
||||
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
|
||||
|
||||
-- | Converts a 'Full.Type' a type into a string.
|
||||
type' :: Full.Type -> Lazy.Text
|
||||
type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
|
||||
type' (Full.TypeList x) = listType x
|
||||
type' (Full.TypeNonNull x) = nonNullType x
|
||||
-- | Converts a 'Type' a type into a string.
|
||||
type' :: Type -> Lazy.Text
|
||||
type' (TypeNamed x) = Lazy.Text.fromStrict x
|
||||
type' (TypeList x) = listType x
|
||||
type' (TypeNonNull x) = nonNullType x
|
||||
|
||||
listType :: Full.Type -> Lazy.Text
|
||||
listType :: Type -> Lazy.Text
|
||||
listType x = brackets (type' x)
|
||||
|
||||
nonNullType :: Full.NonNullType -> Lazy.Text
|
||||
nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||
nonNullType (Full.NonNullTypeList x) = listType x <> "!"
|
||||
nonNullType :: NonNullType -> Lazy.Text
|
||||
nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
|
||||
nonNullType (NonNullTypeList x) = listType x <> "!"
|
||||
|
||||
-- * Internal
|
||||
|
||||
|
|
|
@ -403,32 +403,38 @@ typeCondition = symbol "on" *> name
|
|||
|
||||
value :: Parser Value
|
||||
value = Variable <$> variable
|
||||
<|> Float <$> try float
|
||||
<|> Int <$> integer
|
||||
<|> Boolean <$> booleanValue
|
||||
<|> Null <$ symbol "null"
|
||||
<|> String <$> blockString
|
||||
<|> String <$> string
|
||||
<|> Enum <$> try enumValue
|
||||
<|> List <$> listValue
|
||||
<|> Object <$> objectValue
|
||||
<|> Float <$> try float
|
||||
<|> Int <$> integer
|
||||
<|> Boolean <$> booleanValue
|
||||
<|> Null <$ symbol "null"
|
||||
<|> String <$> blockString
|
||||
<|> String <$> string
|
||||
<|> Enum <$> try enumValue
|
||||
<|> List <$> brackets (some value)
|
||||
<|> Object <$> braces (some $ objectField value)
|
||||
<?> "value error!"
|
||||
where
|
||||
booleanValue :: Parser Bool
|
||||
booleanValue = True <$ symbol "true"
|
||||
<|> False <$ symbol "false"
|
||||
|
||||
listValue :: Parser [Value]
|
||||
listValue = brackets $ some value
|
||||
constValue :: Parser ConstValue
|
||||
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]
|
||||
objectValue = braces $ some objectField
|
||||
booleanValue :: Parser Bool
|
||||
booleanValue = True <$ symbol "true"
|
||||
<|> False <$ symbol "false"
|
||||
|
||||
enumValue :: Parser Name
|
||||
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
|
||||
|
||||
objectField :: Parser ObjectField
|
||||
objectField = ObjectField <$> name <* colon <*> value
|
||||
objectField :: Parser a -> Parser (ObjectField a)
|
||||
objectField valueParser = ObjectField <$> name <* colon <*> valueParser
|
||||
|
||||
-- * Variables
|
||||
|
||||
|
@ -446,8 +452,8 @@ variableDefinition = VariableDefinition
|
|||
variable :: Parser Name
|
||||
variable = dollar *> name
|
||||
|
||||
defaultValue :: Parser (Maybe Value)
|
||||
defaultValue = optional (equals *> value) <?> "DefaultValue"
|
||||
defaultValue :: Parser (Maybe ConstValue)
|
||||
defaultValue = optional (equals *> constValue) <?> "DefaultValue"
|
||||
|
||||
-- * Input Types
|
||||
|
||||
|
|
|
@ -5,21 +5,20 @@
|
|||
module Language.GraphQL.Error
|
||||
( parseError
|
||||
, CollectErrsT
|
||||
, Resolution(..)
|
||||
, addErr
|
||||
, addErrMsg
|
||||
, runCollectErrs
|
||||
, runAppendErrs
|
||||
, singleError
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.State (StateT, modify, runStateT)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State ( StateT
|
||||
, modify
|
||||
, runStateT
|
||||
)
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import Language.GraphQL.Type.Schema
|
||||
import Text.Megaparsec
|
||||
( ParseErrorBundle(..)
|
||||
, PosState(..)
|
||||
|
@ -30,6 +29,12 @@ import Text.Megaparsec
|
|||
, unPos
|
||||
)
|
||||
|
||||
-- | Executor context.
|
||||
data Resolution m = Resolution
|
||||
{ errors :: [Aeson.Value]
|
||||
, types :: HashMap Name (Type m)
|
||||
}
|
||||
|
||||
-- | Wraps a parse error into a list of errors.
|
||||
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
|
||||
parseError ParseErrorBundle{..} =
|
||||
|
@ -46,11 +51,13 @@ parseError ParseErrorBundle{..} =
|
|||
in (errorObject x sourcePosition : result, newState)
|
||||
|
||||
-- | 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.
|
||||
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 s = Aeson.object [("message", Aeson.toJSON s)]
|
||||
|
@ -66,23 +73,17 @@ singleError message = Aeson.object
|
|||
addErrMsg :: Monad m => Text -> CollectErrsT m ()
|
||||
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
|
||||
-- list, which is then sent back with the data.
|
||||
runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value
|
||||
runCollectErrs res = do
|
||||
(dat, errs) <- runStateT res []
|
||||
if null errs
|
||||
runCollectErrs :: Monad m
|
||||
=> HashMap Name (Type m)
|
||||
-> CollectErrsT m Aeson.Value
|
||||
-> m Aeson.Value
|
||||
runCollectErrs types' res = do
|
||||
(dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' }
|
||||
if null errors
|
||||
then return $ Aeson.object [("data", dat)]
|
||||
else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]
|
||||
|
||||
-- | Runs the given computation, collecting the errors and appending them
|
||||
-- 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
|
||||
else return $ Aeson.object
|
||||
[ ("data", dat)
|
||||
, ("errors", Aeson.toJSON $ reverse errors)
|
||||
]
|
||||
|
|
|
@ -1,5 +1,3 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module provides functions to execute a @GraphQL@ request.
|
||||
module Language.GraphQL.Execute
|
||||
( execute
|
||||
|
@ -7,33 +5,30 @@ module Language.GraphQL.Execute
|
|||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.AST.Core as AST.Core
|
||||
import Language.GraphQL.AST.Document (Document, Name)
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Execute.Execution
|
||||
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||
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
|
||||
-- to the resulting fields.
|
||||
--
|
||||
-- Returns the result of the query against the schema wrapped in a /data/
|
||||
-- field, or errors wrapped in an /errors/ field.
|
||||
execute :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||
-> Schema.Subs -- ^ Variable substitution function.
|
||||
execute :: (Monad m, VariableValue a)
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> HashMap.HashMap Name a -- ^ Variable substitution function.
|
||||
-> Document -- @GraphQL@ document.
|
||||
-> m Aeson.Value
|
||||
execute schema subs doc =
|
||||
maybe transformError (document schema Nothing)
|
||||
$ Transform.document subs doc
|
||||
where
|
||||
transformError = return $ singleError "Schema transformation error."
|
||||
execute schema = executeRequest schema Nothing
|
||||
|
||||
-- | 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
|
||||
|
@ -41,46 +36,36 @@ execute schema subs doc =
|
|||
--
|
||||
-- Returns the result of the query against the schema wrapped in a /data/
|
||||
-- field, or errors wrapped in an /errors/ field.
|
||||
executeWithName :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
|
||||
executeWithName :: (Monad m, VariableValue a)
|
||||
=> Schema m -- ^ Resolvers
|
||||
-> Text -- ^ Operation name.
|
||||
-> Schema.Subs -- ^ Variable substitution function.
|
||||
-> HashMap.HashMap Name a -- ^ Variable substitution function.
|
||||
-> Document -- ^ @GraphQL@ Document.
|
||||
-> m Aeson.Value
|
||||
executeWithName schema name subs doc =
|
||||
maybe transformError (document schema $ Just name)
|
||||
$ Transform.document subs doc
|
||||
where
|
||||
transformError = return $ singleError "Schema transformation error."
|
||||
executeWithName schema operationName =
|
||||
executeRequest schema (Just operationName)
|
||||
|
||||
document :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m))
|
||||
executeRequest :: (Monad m, VariableValue a)
|
||||
=> Schema m
|
||||
-> Maybe Text
|
||||
-> AST.Core.Document
|
||||
-> HashMap.HashMap Name a
|
||||
-> Document
|
||||
-> m Aeson.Value
|
||||
document schema Nothing (op :| []) = operation schema op
|
||||
document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of
|
||||
[] -> return $ singleError
|
||||
$ Text.unwords ["Operation", name, "couldn't be found in the document."]
|
||||
(op:_) -> operation schema op
|
||||
where
|
||||
matchingName (AST.Core.Query (Just name') _) = name == name'
|
||||
matchingName (AST.Core.Mutation (Just name') _) = name == name'
|
||||
matchingName _ = False
|
||||
document _ _ _ = return $ singleError "Missing operation name."
|
||||
executeRequest schema operationName subs document =
|
||||
case Transform.document schema operationName subs document of
|
||||
Left queryError -> pure $ singleError $ Transform.queryError queryError
|
||||
Right (Transform.Document types' rootObjectType operation)
|
||||
| (Transform.Query _ fields) <- operation ->
|
||||
executeOperation types' rootObjectType fields
|
||||
| (Transform.Mutation _ fields) <- operation ->
|
||||
executeOperation types' rootObjectType fields
|
||||
|
||||
operation :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m))
|
||||
-> AST.Core.Operation
|
||||
-- This is actually executeMutation, but we don't distinguish between queries
|
||||
-- and mutations yet.
|
||||
executeOperation :: Monad m
|
||||
=> HashMap Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Seq (Transform.Selection m)
|
||||
-> m Aeson.Value
|
||||
operation schema = schemaOperation
|
||||
where
|
||||
runResolver fields = runCollectErrs
|
||||
. flip Schema.resolve fields
|
||||
. Schema.resolversToMap
|
||||
resolve fields queryType = maybe lookupError (runResolver fields)
|
||||
$ HashMap.lookup queryType schema
|
||||
lookupError = pure
|
||||
$ singleError "Root operation type couldn't be found in the schema."
|
||||
schemaOperation (AST.Core.Query _ fields) = resolve fields "Query"
|
||||
schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation"
|
||||
executeOperation types' objectType fields =
|
||||
runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields
|
||||
|
|
|
@ -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 LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
-- | After the document is parsed, before getting executed the AST is
|
||||
-- transformed into a similar, simpler AST. This module is responsible for
|
||||
-- this transformation.
|
||||
-- | After the document is parsed, before getting executed, the AST is
|
||||
-- transformed into a similar, simpler AST. Performed transformations include:
|
||||
--
|
||||
-- * 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
|
||||
( document
|
||||
( Document(..)
|
||||
, Field(..)
|
||||
, Fragment(..)
|
||||
, Input(..)
|
||||
, Operation(..)
|
||||
, QueryError(..)
|
||||
, Selection(..)
|
||||
, document
|
||||
, queryError
|
||||
) where
|
||||
|
||||
import Control.Arrow (first)
|
||||
import Control.Monad (foldM, unless)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
||||
import Control.Monad.Trans.State (State, evalStateT, gets, modify)
|
||||
import Data.Foldable (find)
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import Data.HashMap.Strict (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 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.Core as Core
|
||||
import Language.GraphQL.AST.Document (Definition(..), Document)
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.AST.Core
|
||||
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 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.
|
||||
data Replacement = Replacement
|
||||
{ fragments :: HashMap Core.Name Core.Fragment
|
||||
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
|
||||
-- | Associates a fragment name with a list of 'Field's.
|
||||
data Replacement m = Replacement
|
||||
{ fragments :: HashMap Full.Name (Fragment m)
|
||||
, 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
|
||||
liftJust = lift . lift . Just
|
||||
-- | Represents fragments and inline fragments.
|
||||
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
|
||||
-- for query execution.
|
||||
document :: Schema.Subs -> Document -> Maybe Core.Document
|
||||
document subs document' =
|
||||
flip runReaderT subs
|
||||
$ evalStateT (collectFragments >> operations operationDefinitions)
|
||||
$ Replacement HashMap.empty fragmentTable
|
||||
document :: Coerce.VariableValue a
|
||||
=> forall m
|
||||
. Schema m
|
||||
-> Maybe Full.Name
|
||||
-> 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
|
||||
(fragmentTable, operationDefinitions) = foldr defragment mempty document'
|
||||
defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
|
||||
(definition :) <$> acc
|
||||
defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
|
||||
let (Full.FragmentDefinition name _ _ _) = definition
|
||||
in first (HashMap.insert name definition) acc
|
||||
defragment _ acc = acc
|
||||
defragment' definition (operations, fragments')
|
||||
| (Full.ExecutableDefinition executable) <- definition
|
||||
, (Full.DefinitionOperation operation') <- executable =
|
||||
(transform operation' : operations, fragments')
|
||||
| (Full.ExecutableDefinition executable) <- definition
|
||||
, (Full.DefinitionFragment fragment) <- executable
|
||||
, (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
|
||||
|
||||
operations :: [Full.OperationDefinition] -> TransformT Core.Document
|
||||
operations operations' = do
|
||||
coreOperations <- traverse operation operations'
|
||||
lift . lift $ NonEmpty.nonEmpty coreOperations
|
||||
|
||||
operation :: Full.OperationDefinition -> TransformT Core.Operation
|
||||
operation (Full.SelectionSet sels)
|
||||
= operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
|
||||
operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
|
||||
= Core.Query name <$> appendSelection sels
|
||||
operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
|
||||
= Core.Mutation name <$> appendSelection sels
|
||||
operation :: OperationDefinition -> Replacement m -> Operation m
|
||||
operation operationDefinition replacement
|
||||
= runIdentity
|
||||
$ evalStateT (collectFragments >> transform operationDefinition) replacement
|
||||
where
|
||||
transform (OperationDefinition Full.Query name _ _ sels) =
|
||||
Query name <$> appendSelection sels
|
||||
transform (OperationDefinition Full.Mutation name _ _ sels) =
|
||||
Mutation name <$> appendSelection sels
|
||||
|
||||
-- * Selection
|
||||
|
||||
selection ::
|
||||
Full.Selection ->
|
||||
TransformT (Either (Seq Core.Selection) Core.Selection)
|
||||
selection
|
||||
:: Full.Selection
|
||||
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
||||
selection (Full.Field alias name arguments' directives' selections) =
|
||||
maybe (Left mempty) (Right . Core.SelectionField) <$> do
|
||||
fieldArguments <- arguments arguments'
|
||||
maybe (Left mempty) (Right . SelectionField) <$> do
|
||||
fieldArguments <- foldM go HashMap.empty arguments'
|
||||
fieldSelections <- appendSelection selections
|
||||
fieldDirectives <- Directive.selection <$> directives directives'
|
||||
let field' = Core.Field alias name fieldArguments fieldSelections
|
||||
let field' = Field alias name fieldArguments fieldSelections
|
||||
pure $ field' <$ fieldDirectives
|
||||
where
|
||||
go arguments (Full.Argument name' value') =
|
||||
inputField arguments name' value'
|
||||
|
||||
selection (Full.FragmentSpread name directives') =
|
||||
maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
|
||||
maybe (Left mempty) (Right . SelectionFragment) <$> do
|
||||
spreadDirectives <- Directive.selection <$> directives directives'
|
||||
fragments' <- gets fragments
|
||||
fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
|
||||
pure $ fragment <$ spreadDirectives
|
||||
where
|
||||
lookupDefinition = do
|
||||
|
||||
fragmentDefinitions' <- gets fragmentDefinitions
|
||||
found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
|
||||
fragmentDefinition found
|
||||
case HashMap.lookup name fragments' of
|
||||
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
|
||||
fragmentDirectives <- Directive.selection <$> directives directives'
|
||||
case fragmentDirectives of
|
||||
Nothing -> pure $ Left mempty
|
||||
_ -> do
|
||||
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
|
||||
selectionFragment typeName = Right
|
||||
. Core.SelectionFragment
|
||||
. Core.Fragment typeName
|
||||
. SelectionFragment
|
||||
. Fragment typeName
|
||||
|
||||
appendSelection ::
|
||||
Traversable t =>
|
||||
t Full.Selection ->
|
||||
TransformT (Seq Core.Selection)
|
||||
appendSelection :: Traversable t
|
||||
=> t Full.Selection
|
||||
-> State (Replacement m) (Seq (Selection m))
|
||||
appendSelection = foldM go mempty
|
||||
where
|
||||
go acc sel = append acc <$> selection sel
|
||||
append acc (Left list) = list >< acc
|
||||
append acc (Right one) = one <| acc
|
||||
|
||||
directives :: [Full.Directive] -> TransformT [Core.Directive]
|
||||
directives :: [Full.Directive] -> State (Replacement m) [Directive]
|
||||
directives = traverse directive
|
||||
where
|
||||
directive (Full.Directive directiveName directiveArguments) =
|
||||
Core.Directive directiveName <$> arguments directiveArguments
|
||||
directive (Full.Directive directiveName 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
|
||||
|
||||
-- | Extract fragment definitions into a single 'HashMap'.
|
||||
collectFragments :: TransformT ()
|
||||
collectFragments :: State (Replacement m) ()
|
||||
collectFragments = do
|
||||
fragDefs <- gets fragmentDefinitions
|
||||
let nextValue = head $ HashMap.elems fragDefs
|
||||
|
@ -127,41 +358,79 @@ collectFragments = do
|
|||
_ <- fragmentDefinition nextValue
|
||||
collectFragments
|
||||
|
||||
fragmentDefinition ::
|
||||
Full.FragmentDefinition ->
|
||||
TransformT Core.Fragment
|
||||
lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m))
|
||||
lookupTypeCondition type' = do
|
||||
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
|
||||
modify deleteFragmentDefinition
|
||||
fragmentSelection <- appendSelection selections
|
||||
let newValue = Core.Fragment type' fragmentSelection
|
||||
modify $ insertFragment newValue
|
||||
liftJust newValue
|
||||
compositeType <- lookupTypeCondition type'
|
||||
|
||||
case compositeType of
|
||||
Just compositeType' -> do
|
||||
let newValue = Fragment compositeType' fragmentSelection
|
||||
modify $ insertFragment newValue
|
||||
lift $ pure $ Just newValue
|
||||
_ -> lift $ pure Nothing
|
||||
where
|
||||
deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
|
||||
Replacement fragments' $ HashMap.delete name fragmentDefinitions'
|
||||
insertFragment newValue (Replacement fragments' fragmentDefinitions') =
|
||||
let newFragments = HashMap.insert name newValue fragments'
|
||||
in Replacement newFragments fragmentDefinitions'
|
||||
deleteFragmentDefinition replacement@Replacement{..} =
|
||||
let newDefinitions = HashMap.delete name fragmentDefinitions
|
||||
in replacement{ fragmentDefinitions = newDefinitions }
|
||||
insertFragment newValue replacement@Replacement{..} =
|
||||
let newFragments = HashMap.insert name newValue fragments
|
||||
in replacement{ fragments = newFragments }
|
||||
|
||||
arguments :: [Full.Argument] -> TransformT Core.Arguments
|
||||
arguments = fmap Core.Arguments . foldM go HashMap.empty
|
||||
value :: forall m. Full.Value -> State (Replacement m) Type.Value
|
||||
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
|
||||
go arguments' (Full.Argument name value') = do
|
||||
substitutedValue <- value value'
|
||||
return $ HashMap.insert name substitutedValue arguments'
|
||||
objectField (Full.ObjectField name value') = (name,) <$> value value'
|
||||
|
||||
value :: Full.Value -> TransformT Core.Value
|
||||
value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
|
||||
value (Full.Int i) = pure $ Core.Int i
|
||||
value (Full.Float f) = pure $ Core.Float f
|
||||
value (Full.String x) = pure $ Core.String x
|
||||
value (Full.Boolean b) = pure $ Core.Boolean b
|
||||
value Full.Null = pure Core.Null
|
||||
value (Full.Enum e) = pure $ Core.Enum e
|
||||
value (Full.List l) =
|
||||
Core.List <$> traverse value l
|
||||
value (Full.Object o) =
|
||||
Core.Object . HashMap.fromList <$> traverse objectField o
|
||||
input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
|
||||
input (Full.Variable name) =
|
||||
gets (fmap Variable . HashMap.lookup name . variableValues)
|
||||
input (Full.Int int) = pure $ pure $ Int int
|
||||
input (Full.Float float) = pure $ pure $ Float float
|
||||
input (Full.String string) = pure $ pure $ String string
|
||||
input (Full.Boolean boolean) = pure $ pure $ Boolean boolean
|
||||
input Full.Null = pure $ pure Null
|
||||
input (Full.Enum enum) = pure $ pure $ Enum enum
|
||||
input (Full.List list) = pure . List <$> traverse value list
|
||||
input (Full.Object object) = do
|
||||
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)
|
||||
objectField (Full.ObjectField name value') = (name,) <$> value value'
|
||||
inputField :: forall m
|
||||
. 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.
|
||||
module Language.GraphQL.Trans
|
||||
( ActionT(..)
|
||||
( argument
|
||||
, ActionT(..)
|
||||
, Context(..)
|
||||
, argument
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
|
@ -14,12 +14,15 @@ import Control.Monad.Trans.Reader (ReaderT, asks)
|
|||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.AST.Core
|
||||
import Language.GraphQL.Type.Definition
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
-- | Resolution context holds resolver arguments.
|
||||
newtype Context = Context
|
||||
data Context = Context
|
||||
{ arguments :: Arguments
|
||||
, values :: Value
|
||||
}
|
||||
|
||||
-- | Monad transformer stack used by the resolvers to provide error handling
|
||||
|
@ -54,7 +57,7 @@ instance Monad m => MonadPlus (ActionT m) where
|
|||
mplus = (<|>)
|
||||
|
||||
-- | 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).
|
||||
argument :: Monad m => Name -> ActionT m Value
|
||||
argument argumentName = do
|
||||
|
|
|
@ -1,55 +1,16 @@
|
|||
-- | Definitions for @GraphQL@ input types.
|
||||
-- | Reexports non-conflicting type system and schema definitions.
|
||||
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
|
||||
|
||||
import Data.Aeson as Aeson (ToJSON, toJSON)
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
-- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
|
||||
-- type can wrap other wrapping or named types. Wrapping types are lists and
|
||||
-- Non-Null types (named types are nullable by default).
|
||||
--
|
||||
-- This 'Wrapping' type doesn\'t reflect this distinction exactly but it is
|
||||
-- used in the resolvers to take into account that the returned value can be
|
||||
-- nullable or an (arbitrary nested) list.
|
||||
data Wrapping a
|
||||
= List [Wrapping a] -- ^ Arbitrary nested list
|
||||
| Named a -- ^ Named type without further wrapping
|
||||
| Null -- ^ Null
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Functor Wrapping where
|
||||
fmap f (List list) = List $ fmap (fmap f) list
|
||||
fmap f (Named named) = Named $ f named
|
||||
fmap _ Null = Null
|
||||
|
||||
instance Foldable Wrapping where
|
||||
foldr f acc (List list) = foldr (flip $ foldr f) acc list
|
||||
foldr f acc (Named named) = f named acc
|
||||
foldr _ acc Null = acc
|
||||
|
||||
instance Traversable Wrapping where
|
||||
traverse f (List list) = List <$> traverse (traverse f) list
|
||||
traverse f (Named named) = Named <$> f named
|
||||
traverse _ Null = pure Null
|
||||
|
||||
instance Applicative Wrapping where
|
||||
pure = Named
|
||||
Null <*> _ = Null
|
||||
_ <*> Null = Null
|
||||
(Named f) <*> (Named x) = Named $ f x
|
||||
(List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs
|
||||
(Named f) <*> list = f <$> list
|
||||
(List fs) <*> named = List $ (<*> named) <$> fs
|
||||
|
||||
instance Monad Wrapping where
|
||||
return = pure
|
||||
Null >>= _ = Null
|
||||
(Named x) >>= f = f x
|
||||
(List xs) >>= f = List $ fmap (>>= f) xs
|
||||
|
||||
instance ToJSON a => ToJSON (Wrapping a) where
|
||||
toJSON (List list) = toJSON list
|
||||
toJSON (Named named) = toJSON named
|
||||
toJSON Null = Aeson.Null
|
||||
import Language.GraphQL.Type.Definition
|
||||
import Language.GraphQL.Type.Schema (Schema(..))
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
|
|
@ -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 #-}
|
||||
|
||||
module Language.GraphQL.Type.Directive
|
||||
( selection
|
||||
( Directive(..)
|
||||
, selection
|
||||
) where
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.AST.Core
|
||||
import Language.GraphQL.Type.Definition
|
||||
|
||||
-- | Directive.
|
||||
data Directive = Directive Name Arguments
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Directive processing 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:
|
||||
- .
|
||||
|
|
|
@ -8,7 +8,7 @@ import Data.List.NonEmpty (NonEmpty(..))
|
|||
import Language.GraphQL.AST.Document
|
||||
import Language.GraphQL.AST.Parser
|
||||
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.RawString.QQ (r)
|
||||
|
||||
|
@ -141,4 +141,11 @@ spec = describe "Parser" $ do
|
|||
extend type Story {
|
||||
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
|
||||
) where
|
||||
|
||||
import Data.Aeson (Value, object, (.=))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Aeson (object, (.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||
experimentalResolver = HashMap.singleton "Query"
|
||||
$ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
|
||||
experimentalResolver :: Schema IO
|
||||
experimentalResolver = Schema { query = queryType, mutation = Nothing }
|
||||
where
|
||||
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
|
||||
[ "data" .= object []
|
||||
]
|
||||
|
@ -27,17 +30,17 @@ spec :: Spec
|
|||
spec =
|
||||
describe "Directive executor" $ do
|
||||
it "should be able to @skip fields" $ do
|
||||
let query = [r|
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
experimentalField @skip(if: true)
|
||||
}
|
||||
|]
|
||||
|
||||
actual <- graphql experimentalResolver query
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldBe` emptyObject
|
||||
|
||||
it "should not skip fields if @skip is false" $ do
|
||||
let query = [r|
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
experimentalField @skip(if: false)
|
||||
}
|
||||
|
@ -48,21 +51,21 @@ spec =
|
|||
]
|
||||
]
|
||||
|
||||
actual <- graphql experimentalResolver query
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldBe` expected
|
||||
|
||||
it "should skip fields if @include is false" $ do
|
||||
let query = [r|
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
experimentalField @include(if: false)
|
||||
}
|
||||
|]
|
||||
|
||||
actual <- graphql experimentalResolver query
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldBe` emptyObject
|
||||
|
||||
it "should be able to @skip a fragment spread" $ do
|
||||
let query = [r|
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
...experimentalFragment @skip(if: true)
|
||||
}
|
||||
|
@ -72,11 +75,11 @@ spec =
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql experimentalResolver query
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldBe` emptyObject
|
||||
|
||||
it "should be able to @skip an inline fragment" $ do
|
||||
let query = [r|
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
... on ExperimentalType @skip(if: true) {
|
||||
experimentalField
|
||||
|
@ -84,5 +87,5 @@ spec =
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql experimentalResolver query
|
||||
actual <- graphql experimentalResolver sourceQuery
|
||||
actual `shouldBe` emptyObject
|
||||
|
|
|
@ -4,32 +4,35 @@ module Test.FragmentSpec
|
|||
( spec
|
||||
) where
|
||||
|
||||
import Data.Aeson (Value(..), object, (.=))
|
||||
import Data.Aeson (object, (.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
, shouldBe
|
||||
, shouldSatisfy
|
||||
, shouldNotSatisfy
|
||||
)
|
||||
import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Test.Hspec
|
||||
( Spec
|
||||
, describe
|
||||
, it
|
||||
, shouldBe
|
||||
, shouldNotSatisfy
|
||||
)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
size :: Schema.Resolver IO
|
||||
size = Schema.scalar "size" $ return ("L" :: Text)
|
||||
size :: (Text, Value)
|
||||
size = ("size", String "L")
|
||||
|
||||
circumference :: Schema.Resolver IO
|
||||
circumference = Schema.scalar "circumference" $ return (60 :: Int)
|
||||
circumference :: (Text, Value)
|
||||
circumference = ("circumference", Int 60)
|
||||
|
||||
garment :: Text -> Schema.Resolver IO
|
||||
garment typeName = Schema.object "garment" $ return
|
||||
[ if typeName == "Hat" then circumference else size
|
||||
, Schema.scalar "__typename" $ return typeName
|
||||
]
|
||||
garment :: Text -> (Text, Value)
|
||||
garment typeName =
|
||||
("garment", Object $ HashMap.fromList
|
||||
[ if typeName == "Hat" then circumference else size
|
||||
, ("__typename", String typeName)
|
||||
]
|
||||
)
|
||||
|
||||
inlineQuery :: Text
|
||||
inlineQuery = [r|{
|
||||
|
@ -43,15 +46,52 @@ inlineQuery = [r|{
|
|||
}
|
||||
}|]
|
||||
|
||||
hasErrors :: Value -> Bool
|
||||
hasErrors (Object object') = HashMap.member "errors" object'
|
||||
hasErrors :: Aeson.Value -> Bool
|
||||
hasErrors (Aeson.Object object') = HashMap.member "errors" object'
|
||||
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 = do
|
||||
describe "Inline fragment executor" $ do
|
||||
it "chooses the first selection if the type matches" $ do
|
||||
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery
|
||||
actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
|
@ -62,7 +102,7 @@ spec = do
|
|||
in actual `shouldBe` expected
|
||||
|
||||
it "chooses the last selection if the type matches" $ do
|
||||
actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery
|
||||
actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
|
@ -73,7 +113,7 @@ spec = do
|
|||
in actual `shouldBe` expected
|
||||
|
||||
it "embeds inline fragments without type" $ do
|
||||
let query = [r|{
|
||||
let sourceQuery = [r|{
|
||||
garment {
|
||||
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
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
|
@ -95,18 +135,18 @@ spec = do
|
|||
in actual `shouldBe` expected
|
||||
|
||||
it "evaluates fragments on Query" $ do
|
||||
let query = [r|{
|
||||
let sourceQuery = [r|{
|
||||
... {
|
||||
size
|
||||
}
|
||||
}|]
|
||||
|
||||
actual <- graphql (HashMap.singleton "Query" $ size :| []) query
|
||||
actual <- graphql (toSchema "size" size) sourceQuery
|
||||
actual `shouldNotSatisfy` hasErrors
|
||||
|
||||
describe "Fragment spread executor" $ do
|
||||
it "evaluates fragment spreads" $ do
|
||||
let query = [r|
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
...circumferenceFragment
|
||||
}
|
||||
|
@ -116,7 +156,7 @@ spec = do
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
|
||||
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
|
@ -125,7 +165,7 @@ spec = do
|
|||
in actual `shouldBe` expected
|
||||
|
||||
it "evaluates nested fragments" $ do
|
||||
let query = [r|
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
garment {
|
||||
...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
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
|
@ -152,7 +192,10 @@ spec = do
|
|||
in actual `shouldBe` expected
|
||||
|
||||
it "rejects recursive fragments" $ do
|
||||
let query = [r|
|
||||
let expected = object
|
||||
[ "data" .= object []
|
||||
]
|
||||
sourceQuery = [r|
|
||||
{
|
||||
...circumferenceFragment
|
||||
}
|
||||
|
@ -162,11 +205,11 @@ spec = do
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
|
||||
actual `shouldSatisfy` hasErrors
|
||||
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||
actual `shouldBe` expected
|
||||
|
||||
it "considers type condition" $ do
|
||||
let query = [r|
|
||||
let sourceQuery = [r|
|
||||
{
|
||||
garment {
|
||||
...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
|
||||
|
|
|
@ -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
|
||||
, id_
|
||||
, homePlanet
|
||||
, name
|
||||
, name_
|
||||
, secretBackstory
|
||||
, typeName
|
||||
) where
|
||||
|
@ -22,7 +22,6 @@ import Control.Monad.Trans.Except (throwE)
|
|||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.Trans
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
|
||||
-- * Data
|
||||
-- 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_ (Right x) = _id_ . _humanChar $ x
|
||||
|
||||
name :: Character -> Text
|
||||
name (Left x) = _name . _droidChar $ x
|
||||
name (Right x) = _name . _humanChar $ x
|
||||
name_ :: Character -> Text
|
||||
name_ (Left x) = _name . _droidChar $ x
|
||||
name_ (Right x) = _name . _humanChar $ x
|
||||
|
||||
friends :: Character -> [ID]
|
||||
friends (Left x) = _friends . _droidChar $ x
|
||||
|
@ -67,8 +66,8 @@ appearsIn :: Character -> [Int]
|
|||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
||||
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
||||
|
||||
secretBackstory :: Character -> ActionT Identity Text
|
||||
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
|
||||
secretBackstory :: ActionT Identity Text
|
||||
secretBackstory = ActionT $ throwE "secretBackstory is secret."
|
||||
|
||||
typeName :: Character -> Text
|
||||
typeName = either (const "Droid") (const "Human")
|
||||
|
@ -184,8 +183,8 @@ getDroid' _ = empty
|
|||
getFriends :: Character -> [Character]
|
||||
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
|
||||
|
||||
getEpisode :: Int -> Maybe (Type.Wrapping Text)
|
||||
getEpisode 4 = pure $ Type.Named "NEWHOPE"
|
||||
getEpisode 5 = pure $ Type.Named "EMPIRE"
|
||||
getEpisode 6 = pure $ Type.Named "JEDI"
|
||||
getEpisode :: Int -> Maybe Text
|
||||
getEpisode 4 = pure "NEW_HOPE"
|
||||
getEpisode 5 = pure "EMPIRE"
|
||||
getEpisode 6 = pure "JEDI"
|
||||
getEpisode _ = empty
|
||||
|
|
|
@ -10,7 +10,6 @@ import Data.Functor.Identity (Identity(..))
|
|||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
import Language.GraphQL.Schema (Subs)
|
||||
import Text.RawString.QQ (r)
|
||||
import Test.Hspec.Expectations (Expectation, shouldBe)
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
|
@ -40,7 +39,7 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
id
|
||||
name
|
||||
friends {
|
||||
name
|
||||
name
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -65,9 +64,9 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
friends {
|
||||
name
|
||||
appearsIn
|
||||
friends {
|
||||
name
|
||||
}
|
||||
friends {
|
||||
name
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -78,7 +77,7 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
, "friends" .= [
|
||||
Aeson.object [
|
||||
"name" .= ("Luke Skywalker" :: Text)
|
||||
, "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
||||
, "friends" .= [
|
||||
Aeson.object [hanName]
|
||||
, Aeson.object [leiaName]
|
||||
|
@ -88,7 +87,7 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
]
|
||||
, Aeson.object [
|
||||
hanName
|
||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
||||
, "friends" .=
|
||||
[ Aeson.object [lukeName]
|
||||
, Aeson.object [leiaName]
|
||||
|
@ -97,7 +96,7 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
]
|
||||
, Aeson.object [
|
||||
leiaName
|
||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
|
||||
, "friends" .=
|
||||
[ Aeson.object [lukeName]
|
||||
, Aeson.object [hanName]
|
||||
|
@ -360,6 +359,6 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
testQuery :: Text -> Aeson.Value -> Expectation
|
||||
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 =
|
||||
runIdentity (graphqlSubs schema f q) `shouldBe` expected
|
||||
|
|
|
@ -1,66 +1,133 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Test.StarWars.Schema
|
||||
( character
|
||||
, droid
|
||||
, hero
|
||||
, human
|
||||
, schema
|
||||
( schema
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Reader (asks)
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Functor.Identity (Identity)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Language.GraphQL.Trans
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
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 Prelude hiding (id)
|
||||
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
||||
|
||||
schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
|
||||
schema = HashMap.singleton "Query" $ hero :| [human, droid]
|
||||
schema :: Schema Identity
|
||||
schema = Schema { query = queryType, mutation = Nothing }
|
||||
where
|
||||
queryType = 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
|
||||
hero = Schema.object "hero" $ do
|
||||
heroObject :: Out.ObjectType Identity
|
||||
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"
|
||||
character $ case episode of
|
||||
Schema.Enum "NEWHOPE" -> getHero 4
|
||||
Schema.Enum "EMPIRE" -> getHero 5
|
||||
Schema.Enum "JEDI" -> getHero 6
|
||||
pure $ character $ case episode of
|
||||
Enum "NEW_HOPE" -> getHero 4
|
||||
Enum "EMPIRE" -> getHero 5
|
||||
Enum "JEDI" -> getHero 6
|
||||
_ -> artoo
|
||||
|
||||
human :: Schema.Resolver Identity
|
||||
human = Schema.wrappedObject "human" $ do
|
||||
human :: ActionT Identity Value
|
||||
human = do
|
||||
id' <- argument "id"
|
||||
case id' of
|
||||
Schema.String i -> do
|
||||
String i -> do
|
||||
humanCharacter <- lift $ return $ getHuman i >>= Just
|
||||
case humanCharacter of
|
||||
Nothing -> return Type.Null
|
||||
Just e -> Type.Named <$> character e
|
||||
Nothing -> pure Null
|
||||
Just e -> pure $ character e
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
droid :: Schema.Resolver Identity
|
||||
droid = Schema.object "droid" $ do
|
||||
droid :: ActionT Identity Value
|
||||
droid = do
|
||||
id' <- argument "id"
|
||||
case id' of
|
||||
Schema.String i -> character =<< getDroid i
|
||||
String i -> character <$> getDroid i
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
character :: Character -> ActionT Identity [Schema.Resolver Identity]
|
||||
character char = return
|
||||
[ Schema.scalar "id" $ return $ id_ char
|
||||
, Schema.scalar "name" $ return $ name char
|
||||
, Schema.wrappedObject "friends"
|
||||
$ traverse character $ Type.List $ Type.Named <$> getFriends char
|
||||
, Schema.wrappedScalar "appearsIn" $ return . Type.List
|
||||
$ catMaybes (getEpisode <$> appearsIn char)
|
||||
, Schema.scalar "secretBackstory" $ secretBackstory char
|
||||
, Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
|
||||
, Schema.scalar "__typename" $ return $ typeName char
|
||||
character :: Character -> Value
|
||||
character char = Object $ HashMap.fromList
|
||||
[ ("id", String $ id_ char)
|
||||
, ("name", String $ name_ char)
|
||||
, ("friends", List $ character <$> getFriends char)
|
||||
, ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
|
||||
, ("homePlanet", String $ either mempty homePlanet char)
|
||||
, ("__typename", String $ typeName char)
|
||||
]
|
||||
|
|
Loading…
Reference in New Issue