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
execution. `FieldResolver` is executed in `ActionT` and the current `Field` is
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
- `Type.Definition` and `Type.Schema` modules. Both contain the first types (but
not all yet) to describe a schema. Public functions that execute queries
- `Type.Definition` contains input and the most output types.
- `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.
- `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
### Fixed

View File

@ -39,7 +39,9 @@ First we build a GraphQL schema.
> schema1 = Schema queryType Nothing
>
> 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.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
>
> 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.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
>
> 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 = "query timeAndHello { time hello }"

View File

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

View File

@ -5,11 +5,13 @@ module Language.GraphQL
) where
import qualified Data.Aeson as Aeson
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)
@ -19,14 +21,14 @@ graphql :: Monad m
=> 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
graphqlSubs :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function.
-> HashMap Name a -- ^ Variable substitution function.
-> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response.
graphqlSubs schema f

View File

@ -3,7 +3,6 @@ module Language.GraphQL.AST.Core
( Alias
, Arguments(..)
, Directive(..)
, Document
, Field(..)
, Fragment(..)
, Name
@ -15,15 +14,11 @@ module Language.GraphQL.AST.Core
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.

View File

@ -9,42 +9,42 @@ module Language.GraphQL.Execute
import qualified Data.Aeson as Aeson
import Data.Foldable (find)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
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.Execute.Coerce
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Definition as Definition
import Language.GraphQL.Type.Schema
-- | Query error types.
data QueryError
= OperationNotFound Text
| OperationNameRequired
| CoercionError
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."
-- | 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
execute :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function.
-> 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 = document 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
@ -52,41 +52,105 @@ 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
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 operationName subs doc =
maybe transformError (document schema $ Just operationName)
$ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
executeWithName schema operationName = document schema (Just operationName)
getOperation
:: Maybe Text
-> AST.Core.Document
-> Either QueryError AST.Core.Operation
getOperation Nothing (operation' :| []) = pure operation'
-> Transform.Document
-> Either QueryError Transform.OperationDefinition
getOperation Nothing (Transform.Document (operation' :| []) _) = pure operation'
getOperation Nothing _ = Left OperationNameRequired
getOperation (Just operationName) document'
| Just operation' <- find matchingName document' = pure operation'
getOperation (Just operationName) (Transform.Document operations _)
| Just operation' <- find matchingName operations = pure operation'
| otherwise = Left $ OperationNotFound operationName
where
matchingName (AST.Core.Query (Just name') _) = operationName == name'
matchingName (AST.Core.Mutation (Just name') _) = operationName == name'
matchingName _ = False
matchingName (Transform.OperationDefinition _ name _ _ _) =
name == Just operationName
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
-> 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
document schema operationName document' =
case getOperation operationName document' of
document schema operationName subs document' =
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'
Right operation' -> operation schema operation'
operation :: Monad m
=> Schema m
@ -96,7 +160,8 @@ operation = schemaOperation
where
resolve queryFields = runCollectErrs
. flip Schema.resolve queryFields
. fields
. fmap getResolver
. Definition.fields
lookupError = pure
$ singleError "Root operation type couldn't be found in the schema."
schemaOperation Schema {query} (AST.Core.Query _ fields') =
@ -105,3 +170,4 @@ operation = schemaOperation
resolve fields' mutation
schemaOperation Schema {mutation = Nothing} (AST.Core.Mutation _ _) =
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 LambdaCase #-}
{-# 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.
module Language.GraphQL.Execute.Transform
( document
( Document(..)
, OperationDefinition(..)
, document
, operation
) 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 Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq, (<|), (><))
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 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 = 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
-- 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 :: Full.Document -> Maybe Document
document ast =
let (operations, fragmentTable) = foldr defragment ([], HashMap.empty) ast
in Document <$> NonEmpty.nonEmpty operations <*> pure fragmentTable
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 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
:: HashMap Full.Name Full.FragmentDefinition
-> Schema.Subs
-> OperationDefinition
-> Maybe Core.Operation
operation fragmentTable subs operationDefinition = flip runReaderT subs
$ evalStateT (collectFragments >> transform operationDefinition)
$ Replacement HashMap.empty fragmentTable
where
transform :: OperationDefinition -> TransformT Core.Operation
transform (OperationDefinition Full.Query name _ _ sels) =
Core.Query name <$> appendSelection sels
transform (OperationDefinition Full.Mutation name _ _ sels) =
Core.Mutation name <$> appendSelection sels
-- * Selection

View File

@ -3,8 +3,7 @@
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Schema
( FieldResolver(..)
, Resolver(..)
( Resolver(..)
, Subs
, object
, resolve
@ -31,21 +30,18 @@ import qualified Data.Text as T
import Language.GraphQL.AST.Core
import Language.GraphQL.Error
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type.Definition as Definition
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 Name (FieldResolver m)
data FieldResolver m
= ValueResolver (ActionT m Aeson.Value)
| NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
data Resolver m = Resolver Name (Definition.FieldResolver m)
-- | Converts resolvers to a map.
resolversToMap :: (Foldable f, Functor f)
=> f (Resolver m)
-> HashMap Text (FieldResolver m)
-> HashMap Text (Definition.FieldResolver m)
resolversToMap = HashMap.fromList . toList . fmap toKV
where
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.
object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
object name = Resolver name
. NestingResolver
. Definition.NestingResolver
. fmap (Type.Named . resolversToMap)
-- | Like 'object' but can be null or a list of objects.
@ -66,19 +62,19 @@ wrappedObject :: Monad m
-> ActionT m (Type.Wrapping [Resolver m])
-> Resolver m
wrappedObject name = Resolver name
. NestingResolver
. Definition.NestingResolver
. (fmap . fmap) 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 = 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.
wrappedScalar :: (Monad m, Aeson.ToJSON a)
=> Name
-> ActionT m (Type.Wrapping a)
-> 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 field@(Field _ _ args _) =
@ -91,11 +87,14 @@ convert Type.Null = Aeson.Null
convert (Type.Named value) = value
convert (Type.List value) = Aeson.toJSON value
withField :: Monad m => Field -> FieldResolver m -> CollectErrsT m Aeson.Object
withField field (ValueResolver resolver) = do
withField :: Monad m
=> Field
-> Definition.FieldResolver m
-> CollectErrsT m Aeson.Object
withField field (Definition.ValueResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver
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
case answer of
Right result -> do
@ -112,7 +111,7 @@ errmsg field errorMessage = do
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
resolve :: Monad m
=> HashMap Text (FieldResolver m)
=> HashMap Text (Definition.FieldResolver m)
-> Seq Selection
-> CollectErrsT m Aeson.Value
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
| otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
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
that <- lift $ resolveFieldValue fakeField resolver
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
( 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
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import Data.Set (Set)
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
-- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType
{ 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
( Schema(..)
, collectReferencedTypes
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL.AST.Core (Name)
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
{ query :: 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:
- .

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

View File

@ -6,7 +6,6 @@ module Test.FragmentSpec
import Data.Aeson (Value(..), object, (.=))
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
@ -50,12 +49,28 @@ hasErrors :: Value -> Bool
hasErrors (Object object') = HashMap.member "errors" object'
hasErrors _ = True
toSchema :: Schema.Resolver IO -> Schema IO
toSchema resolver = Schema { query = queryType, mutation = Nothing }
shirtType :: ObjectType IO
shirtType = ObjectType "Shirt"
$ HashMap.singleton resolverName
$ Field Nothing (ScalarOutputType string) mempty resolve
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"
$ Schema.resolversToMap
$ resolver :| []
$ HashMap.singleton resolverName
$ Field Nothing (ObjectOutputType unionMember) mempty resolve
spec :: Spec
spec = do

View File

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

View File

@ -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)
@ -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

View File

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