Coerce variable values

This commit is contained in:
Eugen Wissner 2020-05-21 10:20:59 +02:00
parent a5c44f30fa
commit c3ecfece03
18 changed files with 713 additions and 111 deletions

View File

@ -12,12 +12,30 @@ and this project adheres to
contain a JSON value or another resolver, which is invoked during the contain a JSON value or another resolver, which is invoked during the
execution. `FieldResolver` is executed in `ActionT` and the current `Field` is execution. `FieldResolver` is executed in `ActionT` and the current `Field` is
passed in the reader and not as an explicit argument. passed in the reader and not as an explicit argument.
- `Execute.Transform.OperationDefinition` is almost the same as
`AST.Document.OperationDefinition`. It is used to unify operations in the
shorthand form and other operations.
- `Execute.Transform.operation` has the prior responsibility of
`Execute.Transform.document`, but transforms only the chosen operation and not
the whole document. `Execute.Transform.document` translates
`AST.Document.Document` into `Execute.Transform.Document`.
### Added ### Added
- `Type.Definition` and `Type.Schema` modules. Both contain the first types (but - `Type.Definition` contains input and the most output types.
not all yet) to describe a schema. Public functions that execute queries - `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 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. operation doesn't match the root Query type in the schema.
- `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
- `AST.Core.Document`. Transforming the whole document is probably not
reasonable since a document can define multiple operations and we're
interested only in one of them. Therefore `Document` was modified and moved to
`Execute.Transform`. It contains only slightly modified AST used to pick the
operation.
## [0.7.0.0] - 2020-05-11 ## [0.7.0.0] - 2020-05-11
### Fixed ### Fixed

View File

@ -39,7 +39,9 @@ First we build a GraphQL schema.
> schema1 = Schema queryType Nothing > schema1 = Schema queryType Nothing
> >
> queryType :: ObjectType IO > queryType :: ObjectType IO
> queryType = ObjectType "Query" $ Schema.resolversToMap $ hello :| [] > queryType = ObjectType "Query"
> $ Field Nothing (ScalarOutputType string) mempty
> <$> Schema.resolversToMap (hello :| [])
> >
> hello :: Schema.Resolver IO > hello :: Schema.Resolver IO
> hello = Schema.scalar "hello" (return ("it's me" :: Text)) > hello = Schema.scalar "hello" (return ("it's me" :: Text))
@ -72,7 +74,9 @@ For this example, we're going to be using time.
> schema2 = Schema queryType2 Nothing > schema2 = Schema queryType2 Nothing
> >
> queryType2 :: ObjectType IO > queryType2 :: ObjectType IO
> queryType2 = ObjectType "Query" $ Schema.resolversToMap $ time :| [] > queryType2 = ObjectType "Query"
> $ Field Nothing (ScalarOutputType string) mempty
> <$> Schema.resolversToMap (time :| [])
> >
> time :: Schema.Resolver IO > time :: Schema.Resolver IO
> time = Schema.scalar "time" $ do > time = Schema.scalar "time" $ do
@ -134,7 +138,9 @@ Now that we have two resolvers, we can define a schema which uses them both.
> schema3 = Schema queryType3 Nothing > schema3 = Schema queryType3 Nothing
> >
> queryType3 :: ObjectType IO > queryType3 :: ObjectType IO
> queryType3 = ObjectType "Query" $ Schema.resolversToMap $ hello :| [time] > queryType3 = ObjectType "Query"
> $ Field Nothing (ScalarOutputType string) mempty
> <$> Schema.resolversToMap (hello :| [time])
> >
> query3 :: Text > query3 :: Text
> query3 = "query timeAndHello { time hello }" > query3 = "query timeAndHello { time hello }"

View File

@ -31,6 +31,7 @@ dependencies:
- containers - containers
- megaparsec - megaparsec
- parser-combinators - parser-combinators
- scientific
- text - text
- transformers - transformers
- unordered-containers - unordered-containers

View File

@ -5,11 +5,13 @@ module Language.GraphQL
) where ) where
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Document
import Language.GraphQL.AST.Parser
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Execute import Language.GraphQL.Execute
import Language.GraphQL.AST.Parser import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
@ -19,14 +21,14 @@ graphql :: Monad m
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document. -> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response. -> m Aeson.Value -- ^ Response.
graphql = flip graphqlSubs mempty graphql = flip graphqlSubs (mempty :: Aeson.Object)
-- | If the text parses correctly as a @GraphQL@ query the substitution is -- | If the text parses correctly as a @GraphQL@ query the substitution is
-- applied to the query and the query is then executed using to the given -- applied to the query and the query is then executed using to the given
-- 'Schema.Resolver's. -- 'Schema.Resolver's.
graphqlSubs :: Monad m graphqlSubs :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function. -> HashMap Name a -- ^ Variable substitution function.
-> Text -- ^ Text representing a @GraphQL@ request document. -> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response. -> m Aeson.Value -- ^ Response.
graphqlSubs schema f graphqlSubs schema f

View File

@ -3,7 +3,6 @@ module Language.GraphQL.AST.Core
( Alias ( Alias
, Arguments(..) , Arguments(..)
, Directive(..) , Directive(..)
, Document
, Field(..) , Field(..)
, Fragment(..) , Fragment(..)
, Name , Name
@ -15,15 +14,11 @@ module Language.GraphQL.AST.Core
import Data.Int (Int32) import Data.Int (Int32)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.List.NonEmpty (NonEmpty)
import Data.Sequence (Seq) import Data.Sequence (Seq)
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST (Alias, Name, TypeCondition) 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. -- | GraphQL has 3 operation types: queries, mutations and subscribtions.
-- --
-- Currently only queries and mutations are supported. -- Currently only queries and mutations are supported.

View File

@ -9,42 +9,42 @@ module Language.GraphQL.Execute
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Foldable (find) import Data.Foldable (find)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import qualified Language.GraphQL.AST.Core as AST.Core import qualified Language.GraphQL.AST.Core as AST.Core
import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error import Language.GraphQL.Error
import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.Definition as Definition
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
-- | Query error types. -- | Query error types.
data QueryError data QueryError
= OperationNotFound Text = OperationNotFound Text
| OperationNameRequired | OperationNameRequired
| CoercionError
queryError :: QueryError -> Text queryError :: QueryError -> Text
queryError (OperationNotFound operationName) = Text.unwords queryError (OperationNotFound operationName) = Text.unwords
["Operation", operationName, "couldn't be found in the document."] ["Operation", operationName, "couldn't be found in the document."]
queryError OperationNameRequired = "Missing operation name." queryError OperationNameRequired = "Missing operation name."
queryError CoercionError = "Coercion error."
-- | The substitution is applied to the document, and the resolvers are applied -- | The substitution is applied to the document, and the resolvers are applied
-- to the resulting fields. -- to the resulting fields.
-- --
-- Returns the result of the query against the schema wrapped in a /data/ -- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field. -- field, or errors wrapped in an /errors/ field.
execute :: Monad m execute :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function. -> HashMap.HashMap Name a -- ^ Variable substitution function.
-> Document -- @GraphQL@ document. -> Document -- @GraphQL@ document.
-> m Aeson.Value -> m Aeson.Value
execute schema subs doc = execute schema = document schema Nothing
maybe transformError (document schema Nothing)
$ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
-- | The substitution is applied to the document, and the resolvers are applied -- | The substitution is applied to the document, and the resolvers are applied
-- to the resulting fields. The operation name can be used if the document -- to the resulting fields. The operation name can be used if the document
@ -52,41 +52,105 @@ execute schema subs doc =
-- --
-- Returns the result of the query against the schema wrapped in a /data/ -- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field. -- field, or errors wrapped in an /errors/ field.
executeWithName :: Monad m executeWithName :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers => Schema m -- ^ Resolvers
-> Text -- ^ Operation name. -> Text -- ^ Operation name.
-> Schema.Subs -- ^ Variable substitution function. -> HashMap.HashMap Name a -- ^ Variable substitution function.
-> Document -- ^ @GraphQL@ Document. -> Document -- ^ @GraphQL@ Document.
-> m Aeson.Value -> m Aeson.Value
executeWithName schema operationName subs doc = executeWithName schema operationName = document schema (Just operationName)
maybe transformError (document schema $ Just operationName)
$ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
getOperation getOperation
:: Maybe Text :: Maybe Text
-> AST.Core.Document -> Transform.Document
-> Either QueryError AST.Core.Operation -> Either QueryError Transform.OperationDefinition
getOperation Nothing (operation' :| []) = pure operation' getOperation Nothing (Transform.Document (operation' :| []) _) = pure operation'
getOperation Nothing _ = Left OperationNameRequired getOperation Nothing _ = Left OperationNameRequired
getOperation (Just operationName) document' getOperation (Just operationName) (Transform.Document operations _)
| Just operation' <- find matchingName document' = pure operation' | Just operation' <- find matchingName operations = pure operation'
| otherwise = Left $ OperationNotFound operationName | otherwise = Left $ OperationNotFound operationName
where where
matchingName (AST.Core.Query (Just name') _) = operationName == name' matchingName (Transform.OperationDefinition _ name _ _ _) =
matchingName (AST.Core.Mutation (Just name') _) = operationName == name' name == Just operationName
matchingName _ = False
document :: Monad m lookupInputType
:: Type
-> HashMap.HashMap Name (Definition.TypeDefinition m)
-> Maybe Definition.InputType
lookupInputType (TypeNamed name) types =
case HashMap.lookup name types of
Just (Definition.ScalarTypeDefinition scalarType) ->
Just $ Definition.ScalarInputType scalarType
Just (Definition.EnumTypeDefinition enumType) ->
Just $ Definition.EnumInputType enumType
Just (Definition.InputObjectTypeDefinition objectType) ->
Just $ Definition.ObjectInputType objectType
_ -> Nothing
lookupInputType (TypeList list) types
= Definition.ListInputType
<$> lookupInputType list types
lookupInputType (TypeNonNull (NonNullTypeNamed nonNull)) types =
case HashMap.lookup nonNull types of
Just (Definition.ScalarTypeDefinition scalarType) ->
Just $ Definition.NonNullScalarInputType scalarType
Just (Definition.EnumTypeDefinition enumType) ->
Just $ Definition.NonNullEnumInputType enumType
Just (Definition.InputObjectTypeDefinition objectType) ->
Just $ Definition.NonNullObjectInputType objectType
_ -> Nothing
lookupInputType (TypeNonNull (NonNullTypeList nonNull)) types
= Definition.NonNullListInputType
<$> lookupInputType nonNull types
coerceVariableValues :: (Monad m, VariableValue a)
=> Schema m
-> Transform.OperationDefinition
-> HashMap.HashMap Name a
-> Either QueryError Schema.Subs
coerceVariableValues schema (Transform.OperationDefinition _ _ variables _ _) values =
let referencedTypes = collectReferencedTypes schema
in maybe (Left CoercionError) Right
$ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables
where
coerceValue referencedTypes variableDefinition coercedValues = do
let VariableDefinition variableName variableTypeName _defaultValue =
variableDefinition
variableType <- lookupInputType variableTypeName referencedTypes
value <- HashMap.lookup variableName values
coercedValue <- coerceVariableValue variableType value
HashMap.insert variableName coercedValue <$> coercedValues
executeRequest :: (Monad m, VariableValue a)
=> Schema m => Schema m
-> Maybe Text -> Maybe Text
-> AST.Core.Document -> HashMap.HashMap Name a
-> Transform.Document
-> Either QueryError (Transform.OperationDefinition, Schema.Subs)
executeRequest schema operationName subs document' = do
operation' <- getOperation operationName document'
coercedValues <- coerceVariableValues schema operation' subs
pure (operation', coercedValues)
document :: (Monad m, VariableValue a)
=> Schema m
-> Maybe Text
-> HashMap.HashMap Name a
-> Document
-> m Aeson.Value -> m Aeson.Value
document schema operationName document' = document schema operationName subs document' =
case getOperation operationName document' of case Transform.document document' of
Just transformed -> executeRequest' transformed
Nothing -> pure $ singleError
"The document doesn't contain any executable operations."
where
transformOperation fragmentTable operation' subs' =
case Transform.operation fragmentTable subs' operation' of
Just operationResult -> operation schema operationResult
Nothing -> pure $ singleError "Schema transformation error."
executeRequest' transformed@(Transform.Document _ fragmentTable) =
case executeRequest schema operationName subs transformed of
Right (operation', subs') -> transformOperation fragmentTable operation' subs'
Left error' -> pure $ singleError $ queryError error' Left error' -> pure $ singleError $ queryError error'
Right operation' -> operation schema operation'
operation :: Monad m operation :: Monad m
=> Schema m => Schema m
@ -96,7 +160,8 @@ operation = schemaOperation
where where
resolve queryFields = runCollectErrs resolve queryFields = runCollectErrs
. flip Schema.resolve queryFields . flip Schema.resolve queryFields
. fields . fmap getResolver
. Definition.fields
lookupError = pure lookupError = pure
$ singleError "Root operation type couldn't be found in the schema." $ singleError "Root operation type couldn't be found in the schema."
schemaOperation Schema {query} (AST.Core.Query _ fields') = schemaOperation Schema {query} (AST.Core.Query _ fields') =
@ -105,3 +170,4 @@ operation = schemaOperation
resolve fields' mutation resolve fields' mutation
schemaOperation Schema {mutation = Nothing} (AST.Core.Mutation _ _) = schemaOperation Schema {mutation = Nothing} (AST.Core.Mutation _ _) =
lookupError lookupError
getResolver (Definition.Field _ _ _ resolver) = resolver

View File

@ -0,0 +1,84 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Types and functions used for input and result coercion.
module Language.GraphQL.Execute.Coerce
( VariableValue(..)
) where
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST.Core
import Language.GraphQL.Type.Definition
-- | 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
:: InputType -- ^ Expected type (variable type given in the query).
-> a -- ^ Variable value being coerced.
-> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise.
instance VariableValue Aeson.Value where
coerceVariableValue _ Aeson.Null = Just Null
coerceVariableValue (ScalarInputTypeDefinition scalarType) value
| (Aeson.String stringValue) <- value = Just $ String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue
| (Aeson.Number numberValue) <- value
, (ScalarType "Float" _) <- scalarType =
Just $ Float $ toRealFloat numberValue
| (Aeson.Number numberValue) <- value = -- ID or Int
Int <$> toBoundedInteger numberValue
coerceVariableValue (EnumInputTypeDefinition _) (Aeson.String stringValue) =
Just $ Enum stringValue
coerceVariableValue (ObjectInputTypeDefinition objectType) value
| (Aeson.Object objectValue) <- value = do
let (InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue
then Just $ Object resultMap
else Nothing
where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
$ Just (objectValue, HashMap.empty)
matchFieldValues _ _ Nothing = Nothing
matchFieldValues fieldName inputField (Just (objectValue, resultMap)) =
let (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 (ListInputTypeDefinition listType) value
| (Aeson.Array arrayValue) <- value = 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

View File

@ -1,25 +1,28 @@
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
-- | After the document is parsed, before getting executed the AST is -- | After the document is parsed, before getting executed the AST is
-- transformed into a similar, simpler AST. This module is responsible for -- transformed into a similar, simpler AST. This module is responsible for
-- this transformation. -- this transformation.
module Language.GraphQL.Execute.Transform module Language.GraphQL.Execute.Transform
( document ( Document(..)
, OperationDefinition(..)
, document
, operation
) where ) where
import Control.Arrow (first)
import Control.Monad (foldM, unless) import Control.Monad (foldM, unless)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq, (<|), (><)) import Data.Sequence (Seq, (<|), (><))
import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.AST.Core as Core import qualified Language.GraphQL.AST.Core as Core
import Language.GraphQL.AST.Document (Definition(..), Document)
import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Directive as Directive import qualified Language.GraphQL.Type.Directive as Directive
@ -34,36 +37,56 @@ type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
liftJust :: forall a. a -> TransformT a liftJust :: forall a. a -> TransformT a
liftJust = lift . lift . Just liftJust = lift . lift . Just
-- | GraphQL document is a non-empty list of operations.
data Document = Document
(NonEmpty OperationDefinition)
(HashMap Full.Name Full.FragmentDefinition)
data OperationDefinition = OperationDefinition
Full.OperationType
(Maybe Full.Name)
[Full.VariableDefinition]
[Full.Directive]
Full.SelectionSet
-- | Rewrites the original syntax tree into an intermediate representation used -- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution. -- for query execution.
document :: Schema.Subs -> Document -> Maybe Core.Document document :: Full.Document -> Maybe Document
document subs document' = document ast =
flip runReaderT subs let (operations, fragmentTable) = foldr defragment ([], HashMap.empty) ast
$ evalStateT (collectFragments >> operations operationDefinitions) in Document <$> NonEmpty.nonEmpty operations <*> pure fragmentTable
$ Replacement HashMap.empty fragmentTable
where where
(fragmentTable, operationDefinitions) = foldr defragment mempty document' defragment definition (operations, fragments')
defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc = | (Full.ExecutableDefinition executable) <- definition
(definition :) <$> acc , (Full.DefinitionOperation operation') <- executable =
defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc = (transform operation' : operations, fragments')
let (Full.FragmentDefinition name _ _ _) = definition | (Full.ExecutableDefinition executable) <- definition
in first (HashMap.insert name definition) acc , (Full.DefinitionFragment fragment) <- executable
, (Full.FragmentDefinition name _ _ _) <- fragment =
(operations, HashMap.insert name fragment fragments')
defragment _ acc = acc defragment _ acc = acc
transform = \case
Full.OperationDefinition type' name variables directives' selections ->
OperationDefinition type' name variables directives' selections
Full.SelectionSet selectionSet ->
OperationDefinition Full.Query Nothing mempty mempty selectionSet
-- * Operation -- * Operation
operations :: [Full.OperationDefinition] -> TransformT Core.Document operation
operations operations' = do :: HashMap Full.Name Full.FragmentDefinition
coreOperations <- traverse operation operations' -> Schema.Subs
lift . lift $ NonEmpty.nonEmpty coreOperations -> OperationDefinition
-> Maybe Core.Operation
operation :: Full.OperationDefinition -> TransformT Core.Operation operation fragmentTable subs operationDefinition = flip runReaderT subs
operation (Full.SelectionSet sels) $ evalStateT (collectFragments >> transform operationDefinition)
= operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels $ Replacement HashMap.empty fragmentTable
operation (Full.OperationDefinition Full.Query name _vars _dirs sels) where
= Core.Query name <$> appendSelection sels transform :: OperationDefinition -> TransformT Core.Operation
operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) transform (OperationDefinition Full.Query name _ _ sels) =
= Core.Mutation name <$> appendSelection sels Core.Query name <$> appendSelection sels
transform (OperationDefinition Full.Mutation name _ _ sels) =
Core.Mutation name <$> appendSelection sels
-- * Selection -- * Selection

View File

@ -3,8 +3,7 @@
-- | This module provides a representation of a @GraphQL@ Schema in addition to -- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas. -- functions for defining and manipulating schemas.
module Language.GraphQL.Schema module Language.GraphQL.Schema
( FieldResolver(..) ( Resolver(..)
, Resolver(..)
, Subs , Subs
, object , object
, resolve , resolve
@ -31,21 +30,18 @@ import qualified Data.Text as T
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Core
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Trans import Language.GraphQL.Trans
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type as Type
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
-- information (if an error has occurred). @m@ is an arbitrary monad, usually -- information (if an error has occurred). @m@ is an arbitrary monad, usually
-- 'IO'. -- 'IO'.
data Resolver m = Resolver Name (FieldResolver m) data Resolver m = Resolver Name (Definition.FieldResolver m)
data FieldResolver m
= ValueResolver (ActionT m Aeson.Value)
| NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
-- | Converts resolvers to a map. -- | Converts resolvers to a map.
resolversToMap :: (Foldable f, Functor f) resolversToMap :: (Foldable f, Functor f)
=> f (Resolver m) => f (Resolver m)
-> HashMap Text (FieldResolver m) -> HashMap Text (Definition.FieldResolver m)
resolversToMap = HashMap.fromList . toList . fmap toKV resolversToMap = HashMap.fromList . toList . fmap toKV
where where
toKV (Resolver name r) = (name, r) toKV (Resolver name r) = (name, r)
@ -57,7 +53,7 @@ type Subs = HashMap Name Value
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
object name = Resolver name object name = Resolver name
. NestingResolver . Definition.NestingResolver
. fmap (Type.Named . resolversToMap) . fmap (Type.Named . resolversToMap)
-- | Like 'object' but can be null or a list of objects. -- | Like 'object' but can be null or a list of objects.
@ -66,19 +62,19 @@ wrappedObject :: Monad m
-> ActionT m (Type.Wrapping [Resolver m]) -> ActionT m (Type.Wrapping [Resolver m])
-> Resolver m -> Resolver m
wrappedObject name = Resolver name wrappedObject name = Resolver name
. NestingResolver . Definition.NestingResolver
. (fmap . fmap) resolversToMap . (fmap . fmap) resolversToMap
-- | A scalar represents a primitive value, like a string or an integer. -- | 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 :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
scalar name = Resolver name . ValueResolver . fmap Aeson.toJSON scalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
-- | Like 'scalar' but can be null or a list of scalars. -- | Like 'scalar' but can be null or a list of scalars.
wrappedScalar :: (Monad m, Aeson.ToJSON a) wrappedScalar :: (Monad m, Aeson.ToJSON a)
=> Name => Name
-> ActionT m (Type.Wrapping a) -> ActionT m (Type.Wrapping a)
-> Resolver m -> Resolver m
wrappedScalar name = Resolver name . ValueResolver . fmap Aeson.toJSON wrappedScalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a) resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
resolveFieldValue field@(Field _ _ args _) = resolveFieldValue field@(Field _ _ args _) =
@ -91,11 +87,14 @@ convert Type.Null = Aeson.Null
convert (Type.Named value) = value convert (Type.Named value) = value
convert (Type.List value) = Aeson.toJSON value convert (Type.List value) = Aeson.toJSON value
withField :: Monad m => Field -> FieldResolver m -> CollectErrsT m Aeson.Object withField :: Monad m
withField field (ValueResolver resolver) = do => Field
-> Definition.FieldResolver m
-> CollectErrsT m Aeson.Object
withField field (Definition.ValueResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver answer <- lift $ resolveFieldValue field resolver
either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
withField field@(Field _ _ _ seqSelection) (NestingResolver resolver) = do withField field@(Field _ _ _ seqSelection) (Definition.NestingResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver answer <- lift $ resolveFieldValue field resolver
case answer of case answer of
Right result -> do Right result -> do
@ -112,7 +111,7 @@ errmsg field errorMessage = do
-- 'Resolver' to each 'Field'. Resolves into a value containing the -- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information. -- resolved 'Field', or a null value and error information.
resolve :: Monad m resolve :: Monad m
=> HashMap Text (FieldResolver m) => HashMap Text (Definition.FieldResolver m)
-> Seq Selection -> Seq Selection
-> CollectErrsT m Aeson.Value -> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
@ -122,7 +121,7 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
| (Just resolver) <- lookupResolver name = withField fld resolver | (Just resolver) <- lookupResolver name = withField fld resolver
| otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."] | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
tryResolvers (SelectionFragment (Fragment typeCondition selections')) tryResolvers (SelectionFragment (Fragment typeCondition selections'))
| Just (ValueResolver resolver) <- lookupResolver "__typename" = do | Just (Definition.ValueResolver resolver) <- lookupResolver "__typename" = do
let fakeField = Field Nothing "__typename" mempty mempty let fakeField = Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue fakeField resolver that <- lift $ resolveFieldValue fakeField resolver
if Right (Aeson.String typeCondition) == that if Right (Aeson.String typeCondition) == that

View File

@ -1,18 +1,256 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
-- | Types representing GraphQL type system.
module Language.GraphQL.Type.Definition module Language.GraphQL.Type.Definition
( ObjectType(..) ( Argument(..)
, EnumType(..)
, Field(..)
, FieldResolver(..)
, InputField(..)
, InputObjectType(..)
, InputType(..)
, ObjectType(..)
, OutputType(..)
, ScalarType(..)
, TypeDefinition(..)
, pattern EnumInputTypeDefinition
, pattern ListInputTypeDefinition
, pattern ObjectInputTypeDefinition
, pattern ScalarInputTypeDefinition
, pattern EnumOutputTypeDefinition
, pattern ListOutputTypeDefinition
, pattern ObjectOutputTypeDefinition
, pattern ScalarOutputTypeDefinition
, boolean
, float
, id
, int
, string
) where ) where
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.Schema import Language.GraphQL.AST.Core (Name, Value)
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type as Type
import Prelude hiding (id)
type Fields m = HashMap Text (FieldResolver m) -- | Object type definition.
-- | Object Type Definition.
-- --
-- Almost all of the GraphQL types you define will be object types. Object -- Almost all of the GraphQL types you define will be object types. Object
-- types have a name, but most importantly describe their fields. -- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType data ObjectType m = ObjectType
{ name :: Text { name :: Text
, fields :: Fields m , fields :: HashMap Name (Field m)
} }
-- | Output object field definition.
data Field m = Field
(Maybe Text) (OutputType m) (HashMap Name Argument) (FieldResolver m)
-- | 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 FieldResolver m
= ValueResolver (ActionT m Aeson.Value)
| NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
-- | Field argument definition.
data Argument = Argument (Maybe Text) InputType (Maybe 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)
-- | 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) (Set Text)
-- | Single field of an 'InputObjectType'.
data InputField = InputField (Maybe Text) InputType (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)
-- | These types may be used as input types for arguments and directives.
data InputType
= ScalarInputType ScalarType
| EnumInputType EnumType
| ObjectInputType InputObjectType
| ListInputType InputType
| NonNullScalarInputType ScalarType
| NonNullEnumInputType EnumType
| NonNullObjectInputType InputObjectType
| NonNullListInputType InputType
-- | These types may be used as output types as the result of fields.
data OutputType m
= ScalarOutputType ScalarType
| EnumOutputType EnumType
| ObjectOutputType (ObjectType m)
| ListOutputType (OutputType m)
| NonNullScalarOutputType ScalarType
| NonNullEnumOutputType EnumType
| NonNullObjectOutputType (ObjectType m)
| NonNullListOutputType (OutputType m)
-- | These are all of the possible kinds of types.
data TypeDefinition m
= ScalarTypeDefinition ScalarType
| EnumTypeDefinition EnumType
| ObjectTypeDefinition (ObjectType m)
| InputObjectTypeDefinition InputObjectType
-- | 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."
-- | Matches either 'ScalarInputType' or 'NonNullScalarInputType'.
pattern ScalarInputTypeDefinition :: ScalarType -> InputType
pattern ScalarInputTypeDefinition scalarType <-
(isScalarInputType -> Just scalarType)
-- | Matches either 'EnumInputType' or 'NonNullEnumInputType'.
pattern EnumInputTypeDefinition :: EnumType -> InputType
pattern EnumInputTypeDefinition enumType <-
(isEnumInputType -> Just enumType)
-- | Matches either 'ObjectInputType' or 'NonNullObjectInputType'.
pattern ObjectInputTypeDefinition :: InputObjectType -> InputType
pattern ObjectInputTypeDefinition objectType <-
(isObjectInputType -> Just objectType)
-- | Matches either 'ListInputType' or 'NonNullListInputType'.
pattern ListInputTypeDefinition :: InputType -> InputType
pattern ListInputTypeDefinition listType <-
(isListInputType -> Just listType)
{-# COMPLETE EnumInputTypeDefinition
, ListInputTypeDefinition
, ObjectInputTypeDefinition
, ScalarInputTypeDefinition
#-}
pattern ScalarOutputTypeDefinition :: forall m. ScalarType -> OutputType m
pattern ScalarOutputTypeDefinition scalarType <-
(isScalarOutputType -> Just scalarType)
pattern EnumOutputTypeDefinition :: forall m. EnumType -> OutputType m
pattern EnumOutputTypeDefinition enumType <-
(isEnumOutputType -> Just enumType)
pattern ObjectOutputTypeDefinition :: forall m. ObjectType m -> OutputType m
pattern ObjectOutputTypeDefinition objectType <-
(isObjectOutputType -> Just objectType)
pattern ListOutputTypeDefinition :: forall m. OutputType m -> OutputType m
pattern ListOutputTypeDefinition listType <-
(isListOutputType -> Just listType)
{-# COMPLETE ScalarOutputTypeDefinition
, EnumOutputTypeDefinition
, ObjectOutputTypeDefinition
, ListOutputTypeDefinition
#-}
isScalarInputType :: InputType -> Maybe ScalarType
isScalarInputType (ScalarInputType inputType) = Just inputType
isScalarInputType (NonNullScalarInputType inputType) = Just inputType
isScalarInputType _ = Nothing
isObjectInputType :: InputType -> Maybe InputObjectType
isObjectInputType (ObjectInputType inputType) = Just inputType
isObjectInputType (NonNullObjectInputType inputType) = Just inputType
isObjectInputType _ = Nothing
isEnumInputType :: InputType -> Maybe EnumType
isEnumInputType (EnumInputType inputType) = Just inputType
isEnumInputType (NonNullEnumInputType inputType) = Just inputType
isEnumInputType _ = Nothing
isListInputType :: InputType -> Maybe InputType
isListInputType (ListInputType inputType) = Just inputType
isListInputType (NonNullListInputType inputType) = Just inputType
isListInputType _ = Nothing
isScalarOutputType :: forall m. OutputType m -> Maybe ScalarType
isScalarOutputType (ScalarOutputType outputType) = Just outputType
isScalarOutputType (NonNullScalarOutputType outputType) = Just outputType
isScalarOutputType _ = Nothing
isObjectOutputType :: forall m. OutputType m -> Maybe (ObjectType m)
isObjectOutputType (ObjectOutputType outputType) = Just outputType
isObjectOutputType (NonNullObjectOutputType outputType) = Just outputType
isObjectOutputType _ = Nothing
isEnumOutputType :: forall m. OutputType m -> Maybe EnumType
isEnumOutputType (EnumOutputType outputType) = Just outputType
isEnumOutputType (NonNullEnumOutputType outputType) = Just outputType
isEnumOutputType _ = Nothing
isListOutputType :: forall m. OutputType m -> Maybe (OutputType m)
isListOutputType (ListOutputType outputType) = Just outputType
isListOutputType (NonNullListOutputType outputType) = Just outputType
isListOutputType _ = Nothing

View File

@ -1,11 +1,68 @@
{-# LANGUAGE ExplicitForAll #-}
-- | Schema Definition.
module Language.GraphQL.Type.Schema module Language.GraphQL.Type.Schema
( Schema(..) ( Schema(..)
, collectReferencedTypes
) where ) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL.AST.Core (Name)
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
-- | Schema Definition -- | 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 data Schema m = Schema
{ query :: ObjectType m { query :: ObjectType m
, mutation :: Maybe (ObjectType m) , mutation :: Maybe (ObjectType m)
} }
-- | Traverses the schema and finds all referenced types.
collectReferencedTypes :: forall m. Schema m -> HashMap Name (TypeDefinition m)
collectReferencedTypes schema =
let queryTypes = traverseObjectType (query schema) HashMap.empty
in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
where
collect traverser typeName element foundTypes =
let newMap = HashMap.insert typeName element foundTypes
in maybe (traverser newMap) (const foundTypes)
$ HashMap.lookup typeName foundTypes
visitFields (Field _ outputType arguments _) foundTypes
= traverseOutputType outputType
$ foldr visitArguments foundTypes arguments
visitArguments (Argument _ inputType _) = traverseInputType inputType
visitInputFields (InputField _ inputType _) = traverseInputType inputType
traverseInputType (ObjectInputTypeDefinition objectType) =
let (InputObjectType typeName _ inputFields) = objectType
element = InputObjectTypeDefinition objectType
traverser = flip (foldr visitInputFields) inputFields
in collect traverser typeName element
traverseInputType (ListInputTypeDefinition listType) =
traverseInputType listType
traverseInputType (ScalarInputTypeDefinition scalarType) =
let (ScalarType typeName _) = scalarType
in collect Prelude.id typeName (ScalarTypeDefinition scalarType)
traverseInputType (EnumInputTypeDefinition enumType) =
let (EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumTypeDefinition enumType)
traverseOutputType (ObjectOutputTypeDefinition objectType) =
traverseObjectType objectType
traverseOutputType (ListOutputTypeDefinition listType) =
traverseOutputType listType
traverseOutputType (ScalarOutputTypeDefinition scalarType) =
let (ScalarType typeName _) = scalarType
in collect Prelude.id typeName (ScalarTypeDefinition scalarType)
traverseOutputType (EnumOutputTypeDefinition enumType) =
let (EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumTypeDefinition enumType)
traverseObjectType objectType foundTypes =
let (ObjectType typeName objectFields) = objectType
element = ObjectTypeDefinition objectType
traverser = flip (foldr visitFields) objectFields
in collect traverser typeName element foundTypes

View File

@ -1,4 +1,4 @@
resolver: lts-15.12 resolver: lts-15.13
packages: packages:
- . - .

View File

@ -0,0 +1,88 @@
{-# 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 Language.GraphQL.AST.Core
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Definition
import Prelude hiding (id)
import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
singletonInputObject :: InputType
singletonInputObject = ObjectInputType type'
where
type' = InputObjectType "ObjectName" Nothing inputFields
inputFields = HashMap.singleton "field" field
field = InputField Nothing (ScalarInputType string) Nothing
spec :: Spec
spec =
describe "ToGraphQL Aeson" $ do
it "coerces strings" $
let expected = Just (String "asdf")
actual = coerceVariableValue
(ScalarInputType string) (Aeson.String "asdf")
in actual `shouldBe` expected
it "coerces non-null strings" $
let expected = Just (String "asdf")
actual = coerceVariableValue
(NonNullScalarInputType string) (Aeson.String "asdf")
in actual `shouldBe` expected
it "coerces booleans" $
let expected = Just (Boolean True)
actual = coerceVariableValue
(ScalarInputType boolean) (Aeson.Bool True)
in actual `shouldBe` expected
it "coerces zero to an integer" $
let expected = Just (Int 0)
actual = coerceVariableValue
(ScalarInputType int) (Aeson.Number 0)
in actual `shouldBe` expected
it "rejects fractional if an integer is expected" $
let actual = coerceVariableValue
(ScalarInputType int) (Aeson.Number $ scientific 14 (-1))
in actual `shouldSatisfy` isNothing
it "coerces float numbers" $
let expected = Just (Float 1.4)
actual = coerceVariableValue
(ScalarInputType float) (Aeson.Number $ scientific 14 (-1))
in actual `shouldBe` expected
it "coerces IDs" $
let expected = Just (String "1234")
actual = coerceVariableValue
(ScalarInputType id) (Aeson.String "1234")
in actual `shouldBe` expected
it "coerces input objects" $
let actual = 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 = coerceVariableValue
singletonInputObject Aeson.emptyObject
expected = Just $ Object HashMap.empty
in actual `shouldBe` expected
it "fails if input object value contains extra fields" $
let actual = coerceVariableValue singletonInputObject
$ Aeson.object variableFields
variableFields =
[ "field" .= ("asdf" :: Aeson.Value)
, "extra" .= ("qwer" :: Aeson.Value)
]
in actual `shouldSatisfy` isNothing
it "preserves null" $
let actual = coerceVariableValue (ScalarInputType id) Aeson.Null
in actual `shouldBe` Just Null
it "preserves list order" $
let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
listType = (ListInputType $ ScalarInputType string)
actual = coerceVariableValue listType list
expected = Just $ List [String "asdf", String "qwer"]
in actual `shouldBe` expected

View File

@ -7,7 +7,6 @@ module Test.DirectiveSpec
import Data.Aeson (Value(..), object, (.=)) import Data.Aeson (Value(..), object, (.=))
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import Language.GraphQL.Type.Schema (Schema(..)) import Language.GraphQL.Type.Schema (Schema(..))
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe)
@ -16,11 +15,10 @@ import Text.RawString.QQ (r)
experimentalResolver :: Schema IO experimentalResolver :: Schema IO
experimentalResolver = Schema { query = queryType, mutation = Nothing } experimentalResolver = Schema { query = queryType, mutation = Nothing }
where where
resolver = ValueResolver $ pure $ Number 5
queryType = ObjectType "Query" queryType = ObjectType "Query"
$ HashMap.singleton "experimentalField" $ HashMap.singleton "experimentalField"
$ Schema.ValueResolver $ Field Nothing (ScalarOutputType int) mempty resolver
$ pure
$ Number 5
emptyObject :: Value emptyObject :: Value
emptyObject = object emptyObject = object

View File

@ -6,7 +6,6 @@ module Test.FragmentSpec
import Data.Aeson (Value(..), object, (.=)) import Data.Aeson (Value(..), object, (.=))
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Schema as Schema
@ -50,12 +49,28 @@ hasErrors :: Value -> Bool
hasErrors (Object object') = HashMap.member "errors" object' hasErrors (Object object') = HashMap.member "errors" object'
hasErrors _ = True hasErrors _ = True
toSchema :: Schema.Resolver IO -> Schema IO shirtType :: ObjectType IO
toSchema resolver = Schema { query = queryType, mutation = Nothing } shirtType = ObjectType "Shirt"
$ HashMap.singleton resolverName
$ Field Nothing (ScalarOutputType string) mempty resolve
where where
(Schema.Resolver resolverName resolve) = size
hatType :: ObjectType IO
hatType = ObjectType "Hat"
$ HashMap.singleton resolverName
$ Field Nothing (ScalarOutputType int) mempty resolve
where
(Schema.Resolver resolverName resolve) = circumference
toSchema :: Schema.Resolver IO -> Schema IO
toSchema (Schema.Resolver resolverName resolve) = Schema
{ query = queryType, mutation = Nothing }
where
unionMember = if resolverName == "Hat" then hatType else shirtType
queryType = ObjectType "Query" queryType = ObjectType "Query"
$ Schema.resolversToMap $ HashMap.singleton resolverName
$ resolver :| [] $ Field Nothing (ObjectOutputType unionMember) mempty resolve
spec :: Spec spec :: Spec
spec = do spec = do

View File

@ -5,6 +5,7 @@ module Test.RootOperationSpec
) where ) where
import Data.Aeson ((.=), object) import Data.Aeson ((.=), object)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import Language.GraphQL import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Schema as Schema
@ -13,10 +14,18 @@ import Text.RawString.QQ (r)
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
hatType :: ObjectType IO
hatType = ObjectType "Hat"
$ HashMap.singleton resolverName
$ Field Nothing (ScalarOutputType int) mempty resolve
where
(Schema.Resolver resolverName resolve) =
Schema.scalar "circumference" $ pure (60 :: Int)
schema :: Schema IO schema :: Schema IO
schema = Schema schema = Schema
(ObjectType "Query" queryResolvers) (ObjectType "Query" hatField)
(Just $ ObjectType "Mutation" mutationResolvers) (Just $ ObjectType "Mutation" incrementField)
where where
queryResolvers = Schema.resolversToMap $ garment :| [] queryResolvers = Schema.resolversToMap $ garment :| []
mutationResolvers = Schema.resolversToMap $ increment :| [] mutationResolvers = Schema.resolversToMap $ increment :| []
@ -25,6 +34,10 @@ schema = Schema
] ]
increment = Schema.scalar "incrementCircumference" increment = Schema.scalar "incrementCircumference"
$ pure (61 :: Int) $ pure (61 :: Int)
incrementField = Field Nothing (ScalarOutputType int) mempty
<$> mutationResolvers
hatField = Field Nothing (ObjectOutputType hatType) mempty
<$> queryResolvers
spec :: Spec spec :: Spec
spec = spec =

View File

@ -10,7 +10,6 @@ import Data.Functor.Identity (Identity(..))
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL import Language.GraphQL
import Language.GraphQL.Schema (Subs)
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
import Test.Hspec.Expectations (Expectation, shouldBe) import Test.Hspec.Expectations (Expectation, shouldBe)
import Test.Hspec (Spec, describe, it) import Test.Hspec (Spec, describe, it)
@ -360,6 +359,6 @@ spec = describe "Star Wars Query Tests" $ do
testQuery :: Text -> Aeson.Value -> Expectation testQuery :: Text -> Aeson.Value -> Expectation
testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
testQueryParams f q expected = testQueryParams f q expected =
runIdentity (graphqlSubs schema f q) `shouldBe` expected runIdentity (graphqlSubs schema f q) `shouldBe` expected

View File

@ -25,8 +25,8 @@ schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing } schema = Schema { query = queryType, mutation = Nothing }
where where
queryType = ObjectType "Query" queryType = ObjectType "Query"
$ Schema.resolversToMap $ Field Nothing (ScalarOutputType string) mempty
$ hero :| [human, droid] <$> Schema.resolversToMap (hero :| [human, droid])
hero :: Schema.Resolver Identity hero :: Schema.Resolver Identity
hero = Schema.object "hero" $ do hero = Schema.object "hero" $ do