From c3ecfece0358d79dd1da6efbe6ab83e63bf50f88 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 21 May 2020 10:20:59 +0200 Subject: [PATCH] Coerce variable values --- CHANGELOG.md | 22 +- docs/tutorial/tutorial.lhs | 12 +- package.yaml | 1 + src/Language/GraphQL.hs | 12 +- src/Language/GraphQL/AST/Core.hs | 5 - src/Language/GraphQL/Execute.hs | 126 +++++++--- src/Language/GraphQL/Execute/Coerce.hs | 84 +++++++ src/Language/GraphQL/Execute/Transform.hs | 75 ++++-- src/Language/GraphQL/Schema.hs | 33 ++- src/Language/GraphQL/Type/Definition.hs | 250 ++++++++++++++++++- src/Language/GraphQL/Type/Schema.hs | 59 ++++- stack.yaml | 2 +- tests/Language/GraphQL/Execute/CoerceSpec.hs | 88 +++++++ tests/Test/DirectiveSpec.hs | 6 +- tests/Test/FragmentSpec.hs | 25 +- tests/Test/RootOperationSpec.hs | 17 +- tests/Test/StarWars/QuerySpec.hs | 3 +- tests/Test/StarWars/Schema.hs | 4 +- 18 files changed, 713 insertions(+), 111 deletions(-) create mode 100644 src/Language/GraphQL/Execute/Coerce.hs create mode 100644 tests/Language/GraphQL/Execute/CoerceSpec.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index e249e19..7633c5a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index afef8d0..9b04ea3 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -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 }" diff --git a/package.yaml b/package.yaml index 3ae0895..a61aca3 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,7 @@ dependencies: - containers - megaparsec - parser-combinators +- scientific - text - transformers - unordered-containers diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index fff378d..aef23f0 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index 084ae21..d719912 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -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. diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index e1bacbc..e21d5de 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -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 - Left error' -> pure $ singleError $ queryError error' - Right operation' -> operation schema operation' +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' 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 diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs new file mode 100644 index 0000000..5b26faa --- /dev/null +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 5a9eef8..56b2a22 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -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 diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index e76b42e..752ce29 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 016eeb8..5891f71 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index f830c26..fa44694 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index ecf2cde..377fac6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-15.12 +resolver: lts-15.13 packages: - . diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs new file mode 100644 index 0000000..45a647d --- /dev/null +++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs @@ -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 diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index f39c9c0..56bbb12 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 879a9b7..671def5 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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 diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index fc86d04..08955f3 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -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 = diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs index 45fcf42..e9147ff 100644 --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 8b65e22..253c6ca 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -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