diff options
| -rw-r--r-- | CHANGELOG.md | 19 | ||||
| -rw-r--r-- | graphql.cabal | 14 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/DirectiveLocation.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/Error.hs | 79 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 723 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 253 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Internal.hs | 31 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Subscribe.hs | 113 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 610 | ||||
| -rw-r--r-- | src/Language/GraphQL/TH.hs | 38 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Definition.hs | 31 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/In.hs | 1 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/EncoderSpec.hs | 156 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/LexerSpec.hs | 38 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/ParserSpec.hs | 60 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ExecuteSpec.hs | 87 | ||||
| -rw-r--r-- | tests/Language/GraphQL/Validate/RulesSpec.hs | 172 | ||||
| -rw-r--r-- | tests/Test/DirectiveSpec.hs | 12 | ||||
| -rw-r--r-- | tests/Test/FragmentSpec.hs | 48 | ||||
| -rw-r--r-- | tests/Test/RootOperationSpec.hs | 6 |
21 files changed, 1410 insertions, 1089 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 4ab72fd..d22456c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,23 @@ The format is based on and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [1.0.0.0] +## [1.0.1.0] - 2021-09-27 +### Added +- Custom `Show` instance for `Type.Definition.Value` (for error + messages). +- Path information in errors (path to the field throwing the error). +- Deprecation notes in the `Error` module for `Resolution`, `CollectErrsT` and + `runCollectErrs`. These symbols are part of the old executor and aren't used + anymore, it will be deprecated in the future and removed. +- `TH` module with the `gql` quasi quoter. + +### Fixed +- Error messages are more concrete, they also contain type information and + wrong values, where appropriate and possible. +- If the field with an error is Non-Nullable, the error is propagated to the + first nullable field, as required by the specification. + +## [1.0.0.0] - 2021-07-04 ### Added - `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves insertion order. @@ -443,6 +459,7 @@ and this project adheres to ### Added - Data types for the GraphQL language. +[1.0.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.1.0&rev_to=v1.0.0.0 [1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0 [0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0 [0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0 diff --git a/graphql.cabal b/graphql.cabal index b67f4ae..08fb6de 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: graphql -version: 1.0.0.0 +version: 1.0.1.0 synopsis: Haskell GraphQL implementation description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation. category: Language @@ -20,7 +20,9 @@ build-type: Simple extra-source-files: CHANGELOG.md README.md -tested-with: GHC == 8.10.4 +tested-with: + GHC == 8.10.7 + , GHC == 9.0.1 source-repository head type: git @@ -39,6 +41,7 @@ library Language.GraphQL.Execute Language.GraphQL.Execute.Coerce Language.GraphQL.Execute.OrderedMap + Language.GraphQL.TH Language.GraphQL.Type Language.GraphQL.Type.In Language.GraphQL.Type.Out @@ -47,9 +50,6 @@ library Language.GraphQL.Validate.Validation Test.Hspec.GraphQL other-modules: - Language.GraphQL.Execute.Execution - Language.GraphQL.Execute.Internal - Language.GraphQL.Execute.Subscribe Language.GraphQL.Execute.Transform Language.GraphQL.Type.Definition Language.GraphQL.Type.Internal @@ -67,6 +67,7 @@ library , megaparsec >= 9.0.1 && < 9.1 , parser-combinators >= 1.3.0 && < 1.4 , scientific >= 0.3.7 && < 0.4 + , template-haskell >= 2.16 && < 2.18 , text >= 1.2.4 && < 1.3 , transformers >= 0.5.6 && < 0.6 , unordered-containers >= 0.2.14 && < 0.3 @@ -96,14 +97,13 @@ test-suite graphql-test build-depends: QuickCheck >= 2.14.1 && < 2.15 , aeson - , base >= 4.7 && < 5 + , base >= 4.8 && < 5 , conduit , exceptions , graphql , hspec >= 2.8.2 && < 2.9 , hspec-megaparsec >= 2.2.0 && < 2.3 , megaparsec - , raw-strings-qq >= 1.1 && < 1.2 , scientific , text , unordered-containers diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index c7ceee8..4cf9bfd 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -1,6 +1,4 @@ -{- This Source Code Form is subject to the terms of the Mozilla Public License, - v. 2.0. If a copy of the MPL was not distributed with this file, You can - obtain one at https://mozilla.org/MPL/2.0/. -} +{-# LANGUAGE Safe #-} -- | Target AST for parser. module Language.GraphQL.AST diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs index 511225f..d109666 100644 --- a/src/Language/GraphQL/AST/DirectiveLocation.hs +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -1,7 +1,3 @@ -{- This Source Code Form is subject to the terms of the Mozilla Public License, - v. 2.0. If a copy of the MPL was not distributed with this file, You can - obtain one at https://mozilla.org/MPL/2.0/. -} - {-# LANGUAGE Safe #-} -- | Various parts of a GraphQL document can be annotated with directives. diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 2061c20..4e461f0 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -1,3 +1,7 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RecordWildCards #-} @@ -40,12 +44,6 @@ import Text.Megaparsec , unPos ) --- | Executor context. -data Resolution m = Resolution - { errors :: Seq Error - , types :: HashMap Name (Schema.Type m) - } - -- | Wraps a parse error into a list of errors. parseError :: (Applicative f, Serialize a) => ParseErrorBundle Text Void @@ -65,32 +63,6 @@ parseError ParseErrorBundle{..} = sourcePosition = pstateSourcePos newState in (result |> errorObject x sourcePosition, newState) --- | A wrapper to pass error messages around. -type CollectErrsT m = StateT (Resolution m) m - --- | Adds an error to the list of errors. -{-# DEPRECATED #-} -addErr :: Monad m => Error -> CollectErrsT m () -addErr v = modify appender - where - appender :: Monad m => Resolution m -> Resolution m - appender resolution@Resolution{..} = resolution{ errors = errors |> v } - -{-# DEPRECATED #-} -makeErrorMessage :: Text -> Error -makeErrorMessage s = Error s [] [] - --- | Constructs a response object containing only the error with the given --- message. -{-# DEPRECATED #-} -singleError :: Serialize a => Text -> Response a -singleError message = Response null $ Seq.singleton $ Error message [] [] - --- | Convenience function for just wrapping an error message. -{-# DEPRECATED #-} -addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a -addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null - -- | If an error can be associated to a particular field in the GraphQL result, -- it must contain an entry with the key path that details the path of the -- response field which experienced the error. This allows clients to identify @@ -129,8 +101,13 @@ instance Show ResolverException where instance Exception ResolverException +-- * Deprecated + -- | Runs the given query computation, but collects the errors into an error -- list, which is then sent back with the data. +-- +-- /runCollectErrs was part of the old executor and isn't used anymore, it will +-- be deprecated in the future and removed./ runCollectErrs :: (Monad m, Serialize a) => HashMap Name (Schema.Type m) -> CollectErrsT m a @@ -139,3 +116,41 @@ runCollectErrs types' res = do (dat, Resolution{..}) <- runStateT res $ Resolution{ errors = Seq.empty, types = types' } pure $ Response dat errors + +-- | Executor context. +-- +-- /Resolution was part of the old executor and isn't used anymore, it will be +-- deprecated in the future and removed./ +data Resolution m = Resolution + { errors :: Seq Error + , types :: HashMap Name (Schema.Type m) + } + +-- | A wrapper to pass error messages around. +-- +-- /CollectErrsT was part of the old executor and isn't used anymore, it will be +-- deprecated in the future and removed./ +type CollectErrsT m = StateT (Resolution m) m + +-- | Adds an error to the list of errors. +{-# DEPRECATED #-} +addErr :: Monad m => Error -> CollectErrsT m () +addErr v = modify appender + where + appender :: Monad m => Resolution m -> Resolution m + appender resolution@Resolution{..} = resolution{ errors = errors |> v } + +{-# DEPRECATED #-} +makeErrorMessage :: Text -> Error +makeErrorMessage s = Error s [] [] + +-- | Constructs a response object containing only the error with the given +-- message. +{-# DEPRECATED #-} +singleError :: Serialize a => Text -> Response a +singleError message = Response null $ Seq.singleton $ Error message [] [] + +-- | Convenience function for just wrapping an error message. +{-# DEPRECATED #-} +addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a +addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 62754a3..476cc50 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,4 +1,13 @@ -{-# LANGUAGE ExplicitForAll #-} +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute @@ -6,27 +15,210 @@ module Language.GraphQL.Execute , module Language.GraphQL.Execute.Coerce ) where -import Control.Monad.Catch (MonadCatch) +import Conduit (mapMC, (.|)) +import Control.Arrow (left) +import Control.Monad.Catch + ( Exception(..) + , Handler(..) + , MonadCatch(..) + , MonadThrow(..) + , SomeException(..) + , catches + ) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT) +import Control.Monad.Trans.Writer (WriterT(..), runWriterT) +import qualified Control.Monad.Trans.Writer as Writer +import Control.Monad (foldM) +import qualified Language.GraphQL.AST.Document as Full +import Data.Foldable (find) import Data.HashMap.Strict (HashMap) -import Data.Sequence (Seq(..)) +import qualified Data.HashMap.Strict as HashMap +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq import Data.Text (Text) -import qualified Language.GraphQL.AST.Document as Full +import qualified Data.Text as Text +import Data.Typeable (cast) +import GHC.Records (HasField(..)) import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Execute.Execution -import Language.GraphQL.Execute.Internal +import Language.GraphQL.Execute.OrderedMap (OrderedMap) +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap import qualified Language.GraphQL.Execute.Transform as Transform -import qualified Language.GraphQL.Execute.Subscribe as Subscribe +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.Internal as Type.Internal +import Language.GraphQL.Type.Schema (Schema, Type) +import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Error - ( Error - , ResponseEventStream + ( Error(..) , Response(..) - , runCollectErrs + , Path(..) + , ResolverException(..) + , ResponseEventStream ) -import qualified Language.GraphQL.Type.Definition as Definition -import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema import Prelude hiding (null) +newtype ExecutorT m a = ExecutorT + { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a + } + +instance Functor m => Functor (ExecutorT m) where + fmap f = ExecutorT . fmap f . runExecutorT + +instance Applicative m => Applicative (ExecutorT m) where + pure = ExecutorT . pure + ExecutorT f <*> ExecutorT x = ExecutorT $ f <*> x + +instance Monad m => Monad (ExecutorT m) where + ExecutorT x >>= f = ExecutorT $ x >>= runExecutorT . f + +instance MonadTrans ExecutorT where + lift = ExecutorT . lift . lift + +instance MonadThrow m => MonadThrow (ExecutorT m) where + throwM = lift . throwM + +instance MonadCatch m => MonadCatch (ExecutorT m) where + catch (ExecutorT stack) handler = + ExecutorT $ catch stack $ runExecutorT . handler + +data GraphQLException = forall e. Exception e => GraphQLException e + +instance Show GraphQLException where + show (GraphQLException e) = show e + +instance Exception GraphQLException + +graphQLExceptionToException :: Exception e => e -> SomeException +graphQLExceptionToException = toException . GraphQLException + +graphQLExceptionFromException :: Exception e => SomeException -> Maybe e +graphQLExceptionFromException e = do + GraphQLException graphqlException <- fromException e + cast graphqlException + +data ResultException = forall e. Exception e => ResultException e + +instance Show ResultException where + show (ResultException e) = show e + +instance Exception ResultException where + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException + +resultExceptionToException :: Exception e => e -> SomeException +resultExceptionToException = toException . ResultException + +resultExceptionFromException :: Exception e => SomeException -> Maybe e +resultExceptionFromException e = do + ResultException resultException <- fromException e + cast resultException + +data FieldException = forall e. Exception e => FieldException Full.Location [Path] e + +instance Show FieldException where + show (FieldException _ _ e) = displayException e + +instance Exception FieldException where + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException + +data ValueCompletionException = ValueCompletionException String Type.Value + +instance Show ValueCompletionException where + show (ValueCompletionException typeRepresentation found) = concat + [ "Value completion error. Expected type " + , typeRepresentation + , ", found: " + , show found + , "." + ] + +instance Exception ValueCompletionException where + toException = resultExceptionToException + fromException = resultExceptionFromException + +data InputCoercionException = + InputCoercionException String In.Type (Maybe (Full.Node Transform.Input)) + +instance Show InputCoercionException where + show (InputCoercionException argumentName argumentType Nothing) = concat + [ "Required argument \"" + , argumentName + , "\" of type " + , show argumentType + , " not specified." + ] + show (InputCoercionException argumentName argumentType (Just givenValue)) = concat + [ "Argument \"" + , argumentName + , "\" has invalid type. Expected type " + , show argumentType + , ", found: " + , show givenValue + , "." + ] + +instance Exception InputCoercionException where + toException = graphQLExceptionToException + fromException = graphQLExceptionFromException + +newtype ResultCoercionException = ResultCoercionException String + +instance Show ResultCoercionException where + show (ResultCoercionException typeRepresentation) = concat + [ "Unable to coerce result to " + , typeRepresentation + , "." + ] + +instance Exception ResultCoercionException where + toException = resultExceptionToException + fromException = resultExceptionFromException + +-- | Query error types. +data QueryError + = OperationNameRequired + | OperationNotFound String + | CoercionError Full.VariableDefinition + | UnknownInputType Full.VariableDefinition + +tell :: Monad m => Seq Error -> ExecutorT m () +tell = ExecutorT . lift . Writer.tell + +queryError :: QueryError -> Error +queryError OperationNameRequired = + Error{ message = "Operation name is required.", locations = [], path = [] } +queryError (OperationNotFound operationName) = + let queryErrorMessage = Text.concat + [ "Operation \"" + , Text.pack operationName + , "\" not found." + ] + in Error{ message = queryErrorMessage, locations = [], path = [] } +queryError (CoercionError variableDefinition) = + let Full.VariableDefinition variableName _ _ location = variableDefinition + queryErrorMessage = Text.concat + [ "Failed to coerce the variable \"" + , variableName + , "\"." + ] + in Error{ message = queryErrorMessage, locations = [location], path = [] } +queryError (UnknownInputType variableDefinition) = + let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition + queryErrorMessage = Text.concat + [ "Variable \"" + , variableName + , "\" has unknown type \"" + , Text.pack $ show variableTypeName + , "\"." + ] + in Error{ message = queryErrorMessage, locations = [location], path = [] } + -- | 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 -- defines multiple root operations. @@ -39,33 +231,492 @@ execute :: (MonadCatch m, VariableValue a, Serialize b) -> HashMap Full.Name a -- ^ Variable substitution function. -> Full.Document -- @GraphQL@ document. -> m (Either (ResponseEventStream m b) (Response b)) -execute schema' operationName subs document - = either (pure . rightErrorResponse . singleError [] . show) executeRequest - $ Transform.document schema' operationName subs document +execute schema' operationName subs document' = + executeRequest schema' document' (Text.unpack <$> operationName) subs -executeRequest :: (MonadCatch m, Serialize a) - => Transform.Document m +executeRequest :: (MonadCatch m, Serialize a, VariableValue b) + => Schema m + -> Full.Document + -> Maybe String + -> HashMap Full.Name b -> m (Either (ResponseEventStream m a) (Response a)) -executeRequest (Transform.Document types' rootObjectType operation) - | (Transform.Query _ fields objectLocation) <- operation = - Right <$> executeOperation types' rootObjectType objectLocation fields - | (Transform.Mutation _ fields objectLocation) <- operation = - Right <$> executeOperation types' rootObjectType objectLocation fields - | (Transform.Subscription _ fields objectLocation) <- operation - = either rightErrorResponse Left - <$> Subscribe.subscribe types' rootObjectType objectLocation fields - --- This is actually executeMutation, but we don't distinguish between queries --- and mutations yet. -executeOperation :: (MonadCatch m, Serialize a) +executeRequest schema sourceDocument operationName variableValues = do + operationAndVariables <- sequence buildOperation + case operationAndVariables of + Left queryError' -> pure + $ Right + $ Response null $ pure $ queryError queryError' + Right operation + | Transform.Operation Full.Query topSelections _operationLocation <- operation -> + Right <$> executeQuery topSelections schema + | Transform.Operation Full.Mutation topSelections operationLocation <- operation -> + Right <$> executeMutation topSelections schema operationLocation + | Transform.Operation Full.Subscription topSelections operationLocation <- operation -> + either rightErrorResponse Left <$> subscribe topSelections schema operationLocation + where + schemaTypes = Schema.types schema + (operationDefinitions, fragmentDefinitions') = + Transform.document sourceDocument + buildOperation = do + operationDefinition <- getOperation operationDefinitions operationName + coercedVariableValues <- coerceVariableValues + schemaTypes + operationDefinition + variableValues + let replacement = Transform.Replacement + { variableValues = coercedVariableValues + , fragmentDefinitions = fragmentDefinitions' + , visitedFragments = mempty + , types = schemaTypes + } + pure $ flip runReaderT replacement + $ Transform.runTransformT + $ Transform.transform operationDefinition + +rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b) +rightErrorResponse = Right . Response null . pure + +getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition +getOperation [operation] Nothing = Right operation +getOperation operations (Just givenOperationName) + = maybe (Left $ OperationNotFound givenOperationName) Right + $ find findOperationByName operations + where + findOperationByName (Full.OperationDefinition _ (Just operationName) _ _ _ _) = + givenOperationName == Text.unpack operationName + findOperationByName _ = False +getOperation _ _ = Left OperationNameRequired + +executeQuery :: (MonadCatch m, Serialize a) + => Seq (Transform.Selection m) + -> Schema m + -> m (Response a) +executeQuery topSelections schema = do + let queryType = Schema.query schema + (data', errors) <- runWriterT + $ flip runReaderT (Schema.types schema) + $ runExecutorT + $ catch (executeSelectionSet topSelections queryType Type.Null []) + handleException + pure $ Response data' errors + +handleException :: (MonadCatch m, Serialize a) + => FieldException + -> ExecutorT m a +handleException (FieldException fieldLocation errorPath next) = + let newError = constructError next fieldLocation errorPath + in tell (Seq.singleton newError) >> pure null + +constructError :: Exception e => e -> Full.Location -> [Path] -> Error +constructError e fieldLocation errorPath = Error + { message = Text.pack (displayException e) + , path = reverse errorPath + , locations = [fieldLocation] + } + +executeMutation :: (MonadCatch m, Serialize a) + => Seq (Transform.Selection m) + -> Schema m + -> Full.Location + -> m (Response a) +executeMutation topSelections schema operationLocation + | Just mutationType <- Schema.mutation schema = do + (data', errors) <- runWriterT + $ flip runReaderT (Schema.types schema) + $ runExecutorT + $ catch (executeSelectionSet topSelections mutationType Type.Null []) + handleException + pure $ Response data' errors + | otherwise = pure + $ Response null + $ Seq.singleton + $ Error "Schema doesn't support mutations." [operationLocation] [] + +executeSelectionSet :: (MonadCatch m, Serialize a) + => Seq (Transform.Selection m) + -> Out.ObjectType m + -> Type.Value + -> [Path] + -> ExecutorT m a +executeSelectionSet selections objectType objectValue errorPath = do + let groupedFieldSet = collectFields objectType selections + resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet + coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues + where + executeField' fields resolver = + executeField objectValue fields resolver errorPath + Out.ObjectType _ _ _ resolvers = objectType + go fields@(Transform.Field _ fieldName _ _ _ :| _) = + traverse (executeField' fields) $ HashMap.lookup fieldName resolvers + +fieldsSegment :: forall m. NonEmpty (Transform.Field m) -> Path +fieldsSegment (Transform.Field alias fieldName _ _ _ :| _) = + Segment (fromMaybe fieldName alias) + +viewResolver :: Out.Resolver m -> (Out.Field m, Out.Resolve m) +viewResolver (Out.ValueResolver resolverField' resolveFunction) = + (resolverField', resolveFunction) +viewResolver (Out.EventStreamResolver resolverField' resolveFunction _) = + (resolverField', resolveFunction) + +executeField :: forall m a + . (MonadCatch m, Serialize a) + => Type.Value + -> NonEmpty (Transform.Field m) + -> Out.Resolver m + -> [Path] + -> ExecutorT m a +executeField objectValue fields (viewResolver -> resolverPair) errorPath = + let Transform.Field _ fieldName inputArguments _ fieldLocation :| _ = fields + in catches (go fieldName inputArguments) + [ Handler nullResultHandler + , Handler (inputCoercionHandler fieldLocation) + , Handler (resultHandler fieldLocation) + , Handler (resolverHandler fieldLocation) + ] + where + inputCoercionHandler :: (MonadCatch m, Serialize a) + => Full.Location + -> InputCoercionException + -> ExecutorT m a + inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) = + let argumentLocation = getField @"location" valueNode + in exceptionHandler argumentLocation e + inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e + resultHandler :: (MonadCatch m, Serialize a) + => Full.Location + -> ResultException + -> ExecutorT m a + resultHandler = exceptionHandler + resolverHandler :: (MonadCatch m, Serialize a) + => Full.Location + -> ResolverException + -> ExecutorT m a + resolverHandler = exceptionHandler + nullResultHandler :: (MonadCatch m, Serialize a) + => FieldException + -> ExecutorT m a + nullResultHandler e@(FieldException fieldLocation errorPath' next) = + let newError = constructError next fieldLocation errorPath' + in if Out.isNonNullType fieldType + then throwM e + else returnError newError + exceptionHandler errorLocation e = + let newPath = fieldsSegment fields : errorPath + newError = constructError e errorLocation newPath + in if Out.isNonNullType fieldType + then throwM $ FieldException errorLocation newPath e + else returnError newError + returnError newError = tell (Seq.singleton newError) >> pure null + go fieldName inputArguments = do + argumentValues <- coerceArgumentValues argumentTypes inputArguments + resolvedValue <- + resolveFieldValue resolveFunction objectValue fieldName argumentValues + completeValue fieldType fields errorPath resolvedValue + (resolverField, resolveFunction) = resolverPair + Out.Field _ fieldType argumentTypes = resolverField + +resolveFieldValue :: MonadCatch m + => Out.Resolve m + -> Type.Value + -> Full.Name + -> Type.Subs + -> ExecutorT m Type.Value +resolveFieldValue resolver objectValue _fieldName argumentValues = + lift $ runReaderT resolver context + where + context = Type.Context + { Type.arguments = Type.Arguments argumentValues + , Type.values = objectValue + } + +resolveAbstractType :: Monad m + => Type.Internal.AbstractType m + -> Type.Subs + -> ExecutorT m (Maybe (Out.ObjectType m)) +resolveAbstractType abstractType values' + | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do + types' <- ExecutorT ask + case HashMap.lookup typeName types' of + Just (Type.Internal.ObjectType objectType) -> + if Type.Internal.instanceOf objectType abstractType + then pure $ Just objectType + else pure Nothing + _ -> pure Nothing + | otherwise = pure Nothing + +completeValue :: (MonadCatch m, Serialize a) + => Out.Type m + -> NonEmpty (Transform.Field m) + -> [Path] + -> Type.Value + -> ExecutorT m a +completeValue (Out.isNonNullType -> False) _ _ Type.Null = + pure null +completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list) + = foldM go (0, []) list >>= coerceResult outputType . List . snd + where + go (index, accumulator) listItem = do + let updatedPath = Index index : errorPath + completedValue <- completeValue listType fields updatedPath listItem + pure (index + 1, completedValue : accumulator) +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) = + coerceResult outputType $ Int int +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) = + coerceResult outputType $ Boolean boolean +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) = + coerceResult outputType $ Float float +completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) = + coerceResult outputType $ String string +completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) = + let Type.EnumType _ _ enumMembers = enumType + in if HashMap.member enum enumMembers + then coerceResult outputType $ Enum enum + else throwM + $ ValueCompletionException (show outputType) + $ Type.Enum enum +completeValue (Out.ObjectBaseType objectType) fields errorPath result + = executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath +completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result + | Type.Object objectMap <- result = do + let abstractType = Type.Internal.AbstractInterfaceType interfaceType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType + -> executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath + Nothing -> throwM + $ ValueCompletionException (show outputType) result +completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result + | Type.Object objectMap <- result = do + let abstractType = Type.Internal.AbstractUnionType unionType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType + -> executeSelectionSet (mergeSelectionSets fields) objectType result + $ fieldsSegment fields : errorPath + Nothing -> throwM + $ ValueCompletionException (show outputType) result +completeValue outputType _ _ result = + throwM $ ValueCompletionException (show outputType) result + +coerceResult :: (MonadCatch m, Serialize a) + => Out.Type m + -> Output a + -> ExecutorT m a +coerceResult outputType result + | Just serialized <- serialize outputType result = pure serialized + | otherwise = throwM $ ResultCoercionException $ show outputType + +mergeSelectionSets :: MonadCatch m + => NonEmpty (Transform.Field m) + -> Seq (Transform.Selection m) +mergeSelectionSets = foldr forEach mempty + where + forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet' = + selectionSet' <> fieldSelectionSet + +coerceArgumentValues :: MonadCatch m + => HashMap Full.Name In.Argument + -> HashMap Full.Name (Full.Node Transform.Input) + -> m Type.Subs +coerceArgumentValues argumentDefinitions argumentValues = + HashMap.foldrWithKey c pure argumentDefinitions mempty + where + c argumentName argumentType pure' resultMap = + forEach argumentName argumentType resultMap >>= pure' + forEach :: MonadCatch m + => Full.Name + -> In.Argument + -> Type.Subs + -> m Type.Subs + forEach argumentName (In.Argument _ variableType defaultValue) resultMap = do + let matchedMap + = matchFieldValues' argumentName variableType defaultValue + $ Just resultMap + in case matchedMap of + Just matchedValues -> pure matchedValues + Nothing + | Just inputValue <- HashMap.lookup argumentName argumentValues + -> throwM + $ InputCoercionException (Text.unpack argumentName) variableType + $ Just inputValue + | otherwise -> throwM + $ InputCoercionException (Text.unpack argumentName) variableType Nothing + matchFieldValues' = matchFieldValues coerceArgumentValue + $ Full.node <$> argumentValues + coerceArgumentValue inputType (Transform.Int integer) = + coerceInputLiteral inputType (Type.Int integer) + coerceArgumentValue inputType (Transform.Boolean boolean) = + coerceInputLiteral inputType (Type.Boolean boolean) + coerceArgumentValue inputType (Transform.String string) = + coerceInputLiteral inputType (Type.String string) + coerceArgumentValue inputType (Transform.Float float) = + coerceInputLiteral inputType (Type.Float float) + coerceArgumentValue inputType (Transform.Enum enum) = + coerceInputLiteral inputType (Type.Enum enum) + coerceArgumentValue inputType Transform.Null + | In.isNonNullType inputType = Nothing + | otherwise = coerceInputLiteral inputType Type.Null + coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) = + let coerceItem = coerceArgumentValue inputType + in Type.List <$> traverse coerceItem list + coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object) + | In.InputObjectType _ _ inputFields <- inputType = + let go = forEachField object + resultMap = HashMap.foldrWithKey go (pure mempty) inputFields + in Type.Object <$> resultMap + coerceArgumentValue _ (Transform.Variable variable) = pure variable + coerceArgumentValue _ _ = Nothing + forEachField object variableName (In.InputField _ variableType defaultValue) = + matchFieldValues coerceArgumentValue object variableName variableType defaultValue + +collectFields :: Monad m + => Out.ObjectType m + -> Seq (Transform.Selection m) + -> OrderedMap (NonEmpty (Transform.Field m)) +collectFields objectType = foldl forEach OrderedMap.empty + where + forEach groupedFields (Transform.FieldSelection fieldSelection) = + let Transform.Field maybeAlias fieldName _ _ _ = fieldSelection + responseKey = fromMaybe fieldName maybeAlias + in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields + forEach groupedFields (Transform.FragmentSelection selectionFragment) + | Transform.Fragment fragmentType fragmentSelectionSet _ <- selectionFragment + , Type.Internal.doesFragmentTypeApply fragmentType objectType = + let fragmentGroupedFieldSet = + collectFields objectType fragmentSelectionSet + in groupedFields <> fragmentGroupedFieldSet + | otherwise = groupedFields + +coerceVariableValues :: (Monad m, VariableValue b) + => HashMap Full.Name (Schema.Type m) + -> Full.OperationDefinition + -> HashMap Full.Name b + -> Either QueryError Type.Subs +coerceVariableValues types operationDefinition' variableValues + | Full.OperationDefinition _ _ variableDefinitions _ _ _ <- + operationDefinition' + = foldr forEach (Right HashMap.empty) variableDefinitions + | otherwise = pure mempty + where + forEach variableDefinition (Right coercedValues) = + let Full.VariableDefinition variableName variableTypeName defaultValue _ = + variableDefinition + defaultValue' = constValue . Full.node <$> defaultValue + in case Type.Internal.lookupInputType variableTypeName types of + Just variableType -> + maybe (Left $ CoercionError variableDefinition) Right + $ matchFieldValues + coerceVariableValue' + variableValues + variableName + variableType + defaultValue' + $ Just coercedValues + Nothing -> Left $ UnknownInputType variableDefinition + forEach _ coercedValuesOrError = coercedValuesOrError + coerceVariableValue' variableType value' + = coerceVariableValue variableType value' + >>= coerceInputLiteral variableType + +constValue :: Full.ConstValue -> Type.Value +constValue (Full.ConstInt i) = Type.Int i +constValue (Full.ConstFloat f) = Type.Float f +constValue (Full.ConstString x) = Type.String x +constValue (Full.ConstBoolean b) = Type.Boolean b +constValue Full.ConstNull = Type.Null +constValue (Full.ConstEnum e) = Type.Enum e +constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list +constValue (Full.ConstObject o) = + Type.Object $ HashMap.fromList $ constObjectField <$> o + where + constObjectField Full.ObjectField{value = value', ..} = + (name, constValue $ Full.node value') + +subscribe :: (MonadCatch m, Serialize a) + => Seq (Transform.Selection m) + -> Schema m + -> Full.Location + -> m (Either Error (ResponseEventStream m a)) +subscribe fields schema objectLocation + | Just objectType <- Schema.subscription schema = do + let types' = Schema.types schema + sourceStream <- + createSourceEventStream types' objectType objectLocation fields + let traverser = + mapSourceToResponseEvent types' objectType fields + traverse traverser sourceStream + | otherwise = pure $ Left + $ Error "Schema doesn't support subscriptions." [] [] + +mapSourceToResponseEvent :: (MonadCatch m, Serialize a) + => HashMap Full.Name (Type m) + -> Out.ObjectType m + -> Seq (Transform.Selection m) + -> Out.SourceEventStream m + -> m (ResponseEventStream m a) +mapSourceToResponseEvent types' subscriptionType fields sourceStream + = pure + $ sourceStream + .| mapMC (executeSubscriptionEvent types' subscriptionType fields) + +createSourceEventStream :: MonadCatch m => HashMap Full.Name (Type m) -> Out.ObjectType m -> Full.Location -> Seq (Transform.Selection m) - -> m (Response a) -executeOperation types' objectType objectLocation fields - = runCollectErrs types' - $ executeSelectionSet Definition.Null objectType objectLocation fields + -> m (Either Error (Out.SourceEventStream m)) +createSourceEventStream _types subscriptionType objectLocation fields + | [fieldGroup] <- OrderedMap.elems groupedFieldSet + , Transform.Field _ fieldName arguments' _ errorLocation <- + NonEmpty.head fieldGroup + , Out.ObjectType _ _ _ fieldTypes <- subscriptionType + , resolverT <- fieldTypes HashMap.! fieldName + , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT + , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition = + case coerceArgumentValues argumentDefinitions arguments' of + Left _ -> pure + $ Left + $ Error "Argument coercion failed." [errorLocation] [] + Right argumentValues -> left (singleError [errorLocation]) + <$> resolveFieldEventStream Type.Null argumentValues resolver + | otherwise = pure + $ Left + $ Error "Subscription contains more than one field." [objectLocation] [] + where + groupedFieldSet = collectFields subscriptionType fields + singleError :: [Full.Location] -> String -> Error + singleError errorLocations message = Error (Text.pack message) errorLocations [] -rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b) -rightErrorResponse = Right . Response null . pure +resolveFieldEventStream :: MonadCatch m + => Type.Value + -> Type.Subs + -> Out.Subscribe m + -> m (Either String (Out.SourceEventStream m)) +resolveFieldEventStream result args resolver = + catch (Right <$> runReaderT resolver context) handleEventStreamError + where + handleEventStreamError :: MonadCatch m + => ResolverException + -> m (Either String (Out.SourceEventStream m)) + handleEventStreamError = pure . Left . displayException + context = Type.Context + { Type.arguments = Type.Arguments args + , Type.values = result + } + +executeSubscriptionEvent :: (MonadCatch m, Serialize a) + => HashMap Full.Name (Type m) + -> Out.ObjectType m + -> Seq (Transform.Selection m) + -> Type.Value + -> m (Response a) +executeSubscriptionEvent types' objectType fields initialValue = do + (data', errors) <- runWriterT + $ flip runReaderT types' + $ runExecutorT + $ catch (executeSelectionSet fields objectType initialValue []) + handleException + pure $ Response data' errors diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs deleted file mode 100644 index 9ad4439..0000000 --- a/src/Language/GraphQL/Execute/Execution.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Language.GraphQL.Execute.Execution - ( coerceArgumentValues - , collectFields - , executeSelectionSet - ) where - -import Control.Monad.Catch (Exception(..), MonadCatch(..)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (runReaderT) -import Control.Monad.Trans.State (gets) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (fromMaybe) -import Data.Sequence (Seq(..)) -import qualified Data.Text as Text -import qualified Language.GraphQL.AST as Full -import Language.GraphQL.Error -import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Execute.Internal -import Language.GraphQL.Execute.OrderedMap (OrderedMap) -import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap -import qualified Language.GraphQL.Execute.Transform as Transform -import qualified Language.GraphQL.Type as Type -import qualified Language.GraphQL.Type.In as In -import qualified Language.GraphQL.Type.Out as Out -import qualified Language.GraphQL.Type.Internal as Internal -import Prelude hiding (null) - -resolveFieldValue :: MonadCatch m - => Type.Value - -> Type.Subs - -> Type.Resolve m - -> Full.Location - -> CollectErrsT m Type.Value -resolveFieldValue result args resolver location' = - catch (lift $ runReaderT resolver context) handleFieldError - where - handleFieldError :: MonadCatch m - => ResolverException - -> CollectErrsT m Type.Value - handleFieldError e - = addError Type.Null - $ Error (Text.pack $ displayException e) [location'] [] - context = Type.Context - { Type.arguments = Type.Arguments args - , Type.values = result - } - -collectFields :: Monad m - => Out.ObjectType m - -> Seq (Transform.Selection m) - -> OrderedMap (NonEmpty (Transform.Field m)) -collectFields objectType = foldl forEach OrderedMap.empty - where - forEach groupedFields (Transform.SelectionField field) = - let responseKey = aliasOrName field - in OrderedMap.insert responseKey (field :| []) groupedFields - forEach groupedFields (Transform.SelectionFragment selectionFragment) - | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment - , Internal.doesFragmentTypeApply fragmentType objectType = - let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet - in groupedFields <> fragmentGroupedFieldSet - | otherwise = groupedFields - -aliasOrName :: forall m. Transform.Field m -> Full.Name -aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias - -resolveAbstractType :: Monad m - => Internal.AbstractType m - -> Type.Subs - -> CollectErrsT m (Maybe (Out.ObjectType m)) -resolveAbstractType abstractType values' - | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do - types' <- gets types - case HashMap.lookup typeName types' of - Just (Internal.ObjectType objectType) -> - if Internal.instanceOf objectType abstractType - then pure $ Just objectType - else pure Nothing - _ -> pure Nothing - | otherwise = pure Nothing - -executeField :: (MonadCatch m, Serialize a) - => Out.Resolver m - -> Type.Value - -> NonEmpty (Transform.Field m) - -> CollectErrsT m a -executeField fieldResolver prev fields - | Out.ValueResolver fieldDefinition resolver <- fieldResolver = - executeField' fieldDefinition resolver - | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver = - executeField' fieldDefinition resolver - where - executeField' fieldDefinition resolver = do - let Out.Field _ fieldType argumentDefinitions = fieldDefinition - let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields - case coerceArgumentValues argumentDefinitions arguments' of - Left [] -> - let errorMessage = "Not all required arguments are specified." - in addError null $ Error errorMessage [location'] [] - Left errorLocations -> addError null - $ Error "Argument coercing failed." errorLocations [] - Right argumentValues -> do - answer <- resolveFieldValue prev argumentValues resolver location' - completeValue fieldType fields answer - -completeValue :: (MonadCatch m, Serialize a) - => Out.Type m - -> NonEmpty (Transform.Field m) - -> Type.Value - -> CollectErrsT m a -completeValue (Out.isNonNullType -> False) _ Type.Null = pure null -completeValue outputType@(Out.ListBaseType listType) fields (Type.List list) - = traverse (completeValue listType fields) list - >>= coerceResult outputType (firstFieldLocation fields) . List -completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) = - coerceResult outputType (firstFieldLocation fields) $ Int int -completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) = - coerceResult outputType (firstFieldLocation fields) $ Boolean boolean -completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) = - coerceResult outputType (firstFieldLocation fields) $ Float float -completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) = - coerceResult outputType (firstFieldLocation fields) $ String string -completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) = - let Type.EnumType _ _ enumMembers = enumType - location = firstFieldLocation fields - in if HashMap.member enum enumMembers - then coerceResult outputType location $ Enum enum - else addError null $ Error "Enum value completion failed." [location] [] -completeValue (Out.ObjectBaseType objectType) fields result - = executeSelectionSet result objectType (firstFieldLocation fields) - $ mergeSelectionSets fields -completeValue (Out.InterfaceBaseType interfaceType) fields result - | Type.Object objectMap <- result = do - let abstractType = Internal.AbstractInterfaceType interfaceType - let location = firstFieldLocation fields - concreteType <- resolveAbstractType abstractType objectMap - case concreteType of - Just objectType -> executeSelectionSet result objectType location - $ mergeSelectionSets fields - Nothing -> addError null - $ Error "Interface value completion failed." [location] [] -completeValue (Out.UnionBaseType unionType) fields result - | Type.Object objectMap <- result = do - let abstractType = Internal.AbstractUnionType unionType - let location = firstFieldLocation fields - concreteType <- resolveAbstractType abstractType objectMap - case concreteType of - Just objectType -> executeSelectionSet result objectType - location $ mergeSelectionSets fields - Nothing -> addError null - $ Error "Union value completion failed." [location] [] -completeValue _ (Transform.Field _ _ _ _ location :| _) _ = - addError null $ Error "Value completion failed." [location] [] - -mergeSelectionSets :: MonadCatch m - => NonEmpty (Transform.Field m) - -> Seq (Transform.Selection m) -mergeSelectionSets = foldr forEach mempty - where - forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet = - selectionSet <> fieldSelectionSet - -firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location -firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation - -coerceResult :: (MonadCatch m, Serialize a) - => Out.Type m - -> Full.Location - -> Output a - -> CollectErrsT m a -coerceResult outputType parentLocation result - | Just serialized <- serialize outputType result = pure serialized - | otherwise = addError null - $ Error "Result coercion failed." [parentLocation] [] - --- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies --- each field to each 'Transform.Selection'. Resolves into a value containing --- the resolved 'Transform.Selection', or a null value and error information. -executeSelectionSet :: (MonadCatch m, Serialize a) - => Type.Value - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> CollectErrsT m a -executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do - let fields = collectFields objectType selectionSet - resolvedValues <- OrderedMap.traverseMaybe forEach fields - coerceResult (Out.NonNullObjectType objectType) objectLocation - $ Object resolvedValues - where - forEach fields@(field :| _) = - let Transform.Field _ name _ _ _ = field - in traverse (tryResolver fields) $ lookupResolver name - lookupResolver = flip HashMap.lookup resolvers - tryResolver fields resolver = - executeField resolver result fields >>= lift . pure - -coerceArgumentValues - :: HashMap Full.Name In.Argument - -> HashMap Full.Name (Full.Node Transform.Input) - -> Either [Full.Location] Type.Subs -coerceArgumentValues argumentDefinitions argumentNodes = - HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions - where - forEach argumentName (In.Argument _ variableType defaultValue) = \case - Right resultMap - | Just matchedValues - <- matchFieldValues' argumentName variableType defaultValue $ Just resultMap - -> Right matchedValues - | otherwise -> Left $ generateError argumentName [] - Left errorLocations - | Just _ - <- matchFieldValues' argumentName variableType defaultValue $ pure mempty - -> Left errorLocations - | otherwise -> Left $ generateError argumentName errorLocations - generateError argumentName errorLocations = - case HashMap.lookup argumentName argumentNodes of - Just (Full.Node _ errorLocation) -> [errorLocation] - Nothing -> errorLocations - matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes) - coerceArgumentValue inputType (Transform.Int integer) = - coerceInputLiteral inputType (Type.Int integer) - coerceArgumentValue inputType (Transform.Boolean boolean) = - coerceInputLiteral inputType (Type.Boolean boolean) - coerceArgumentValue inputType (Transform.String string) = - coerceInputLiteral inputType (Type.String string) - coerceArgumentValue inputType (Transform.Float float) = - coerceInputLiteral inputType (Type.Float float) - coerceArgumentValue inputType (Transform.Enum enum) = - coerceInputLiteral inputType (Type.Enum enum) - coerceArgumentValue inputType Transform.Null - | In.isNonNullType inputType = Nothing - | otherwise = coerceInputLiteral inputType Type.Null - coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) = - let coerceItem = coerceInputLiteral inputType - in Type.List <$> traverse coerceItem list - coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object) - | In.InputObjectType _ _ inputFields <- inputType = - let go = forEachField object - resultMap = HashMap.foldrWithKey go (pure mempty) inputFields - in Type.Object <$> resultMap - coerceArgumentValue _ (Transform.Variable variable) = pure variable - coerceArgumentValue _ _ = Nothing - forEachField object variableName (In.InputField _ variableType defaultValue) = - matchFieldValues coerceArgumentValue object variableName variableType defaultValue diff --git a/src/Language/GraphQL/Execute/Internal.hs b/src/Language/GraphQL/Execute/Internal.hs deleted file mode 100644 index 046db45..0000000 --- a/src/Language/GraphQL/Execute/Internal.hs +++ /dev/null @@ -1,31 +0,0 @@ -{- This Source Code Form is subject to the terms of the Mozilla Public License, - v. 2.0. If a copy of the MPL was not distributed with this file, You can - obtain one at https://mozilla.org/MPL/2.0/. -} - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Language.GraphQL.Execute.Internal - ( addError - , singleError - ) where - -import Control.Monad.Trans.State (modify) -import Control.Monad.Catch (MonadCatch) -import Data.Sequence ((|>)) -import qualified Data.Text as Text -import qualified Language.GraphQL.AST as Full -import Language.GraphQL.Error (CollectErrsT, Error(..), Resolution(..)) -import Prelude hiding (null) - -addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a -addError returnValue error' = modify appender >> pure returnValue - where - appender :: Resolution m -> Resolution m - appender resolution@Resolution{ errors } = resolution - { errors = errors |> error' - } - -singleError :: [Full.Location] -> String -> Error -singleError errorLocations message = Error (Text.pack message) errorLocations [] diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs deleted file mode 100644 index 5d8d294..0000000 --- a/src/Language/GraphQL/Execute/Subscribe.hs +++ /dev/null @@ -1,113 +0,0 @@ -{- This Source Code Form is subject to the terms of the Mozilla Public License, - v. 2.0. If a copy of the MPL was not distributed with this file, You can - obtain one at https://mozilla.org/MPL/2.0/. -} - -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE OverloadedStrings #-} -module Language.GraphQL.Execute.Subscribe - ( subscribe - ) where - -import Conduit -import Control.Arrow (left) -import Control.Monad.Catch (Exception(..), MonadCatch(..)) -import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.List.NonEmpty as NonEmpty -import Data.Sequence (Seq(..)) -import qualified Language.GraphQL.AST as Full -import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Execute.Execution -import Language.GraphQL.Execute.Internal -import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap -import qualified Language.GraphQL.Execute.Transform as Transform -import Language.GraphQL.Error - ( Error(..) - , ResolverException - , Response - , ResponseEventStream - , runCollectErrs - ) -import qualified Language.GraphQL.Type.Definition as Definition -import qualified Language.GraphQL.Type as Type -import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema - -subscribe :: (MonadCatch m, Serialize a) - => HashMap Full.Name (Type m) - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> m (Either Error (ResponseEventStream m a)) -subscribe types' objectType objectLocation fields = do - sourceStream <- - createSourceEventStream types' objectType objectLocation fields - let traverser = - mapSourceToResponseEvent types' objectType objectLocation fields - traverse traverser sourceStream - -mapSourceToResponseEvent :: (MonadCatch m, Serialize a) - => HashMap Full.Name (Type m) - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> Out.SourceEventStream m - -> m (ResponseEventStream m a) -mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream - = pure - $ sourceStream - .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields) - -createSourceEventStream :: MonadCatch m - => HashMap Full.Name (Type m) - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> m (Either Error (Out.SourceEventStream m)) -createSourceEventStream _types subscriptionType objectLocation fields - | [fieldGroup] <- OrderedMap.elems groupedFieldSet - , Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup - , Out.ObjectType _ _ _ fieldTypes <- subscriptionType - , resolverT <- fieldTypes HashMap.! fieldName - , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT - , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition = - case coerceArgumentValues argumentDefinitions arguments' of - Left _ -> pure - $ Left - $ Error "Argument coercion failed." [errorLocation] [] - Right argumentValues -> left (singleError [errorLocation]) - <$> resolveFieldEventStream Type.Null argumentValues resolver - | otherwise = pure - $ Left - $ Error "Subscription contains more than one field." [objectLocation] [] - where - groupedFieldSet = collectFields subscriptionType fields - -resolveFieldEventStream :: MonadCatch m - => Type.Value - -> Type.Subs - -> Out.Subscribe m - -> m (Either String (Out.SourceEventStream m)) -resolveFieldEventStream result args resolver = - catch (Right <$> runReaderT resolver context) handleEventStreamError - where - handleEventStreamError :: MonadCatch m - => ResolverException - -> m (Either String (Out.SourceEventStream m)) - handleEventStreamError = pure . Left . displayException - context = Type.Context - { Type.arguments = Type.Arguments args - , Type.values = result - } - -executeSubscriptionEvent :: (MonadCatch m, Serialize a) - => HashMap Full.Name (Type m) - -> Out.ObjectType m - -> Full.Location - -> Seq (Transform.Selection m) - -> Definition.Value - -> m (Response a) -executeSubscriptionEvent types' objectType objectLocation fields initialValue - = runCollectErrs types' - $ executeSelectionSet initialValue objectType objectLocation fields diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 117b708..79de094 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -6,7 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} -- | After the document is parsed, before getting executed, the AST is -- transformed into a similar, simpler AST. Performed transformations include: @@ -21,65 +21,87 @@ -- This module is also responsible for smaller rewrites that touch only parts of -- the original AST. module Language.GraphQL.Execute.Transform - ( Document(..) - , Field(..) + ( Field(..) , Fragment(..) , Input(..) , Operation(..) - , QueryError(..) + , Replacement(..) , Selection(..) + , TransformT(..) , document + , transform ) where -import Control.Monad (foldM, unless) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State (State, evalStateT, gets, modify) -import Data.Foldable (find) -import Data.Functor.Identity (Identity(..)) +import Control.Monad (foldM) +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Reader (ReaderT(..), local) +import qualified Control.Monad.Trans.Reader as Reader +import Data.Bifunctor (first) +import Data.Functor ((<&>)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet import Data.Int (Int32) -import Data.Maybe (fromMaybe) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (intercalate) import qualified Data.List.NonEmpty as NonEmpty -import Data.Sequence (Seq, (<|), (><)) +import Data.Maybe (fromMaybe, isJust) +import Data.Sequence (Seq, (><)) +import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text -import qualified Language.GraphQL.AST as Full -import Language.GraphQL.AST (Name) -import qualified Language.GraphQL.Execute.Coerce as Coerce -import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.AST.Document as Full +import Language.GraphQL.Type.Schema (Type) import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Internal as Type -import qualified Language.GraphQL.Type.Out as Out -import qualified Language.GraphQL.Type.Schema as Schema +import Numeric (showFloat) -- | Associates a fragment name with a list of 'Field's. data Replacement m = Replacement - { fragments :: HashMap Full.Name (Fragment m) - , fragmentDefinitions :: FragmentDefinitions - , variableValues :: Type.Subs - , types :: HashMap Full.Name (Schema.Type m) + { variableValues :: Type.Subs + , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition + , visitedFragments :: HashSet Full.Name + , types :: HashMap Full.Name (Type m) } -type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition +newtype TransformT m a = TransformT + { runTransformT :: ReaderT (Replacement m) m a + } --- | Represents fragments and inline fragments. -data Fragment m - = Fragment (Type.CompositeType m) (Seq (Selection m)) +instance Functor m => Functor (TransformT m) where + fmap f = TransformT . fmap f . runTransformT --- | Single selection element. -data Selection m - = SelectionFragment (Fragment m) - | SelectionField (Field m) +instance Applicative m => Applicative (TransformT m) where + pure = TransformT . pure + TransformT f <*> TransformT x = TransformT $ f <*> x + +instance Monad m => Monad (TransformT m) where + TransformT x >>= f = TransformT $ x >>= runTransformT . f + +instance MonadTrans TransformT where + lift = TransformT . lift + +instance MonadThrow m => MonadThrow (TransformT m) where + throwM = lift . throwM + +instance MonadCatch m => MonadCatch (TransformT m) where + catch (TransformT stack) handler = + TransformT $ catch stack $ runTransformT . handler + +asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a +asks = TransformT . Reader.asks -- | GraphQL has 3 operation types: queries, mutations and subscribtions. data Operation m - = Query (Maybe Text) (Seq (Selection m)) Full.Location - | Mutation (Maybe Text) (Seq (Selection m)) Full.Location - | Subscription (Maybe Text) (Seq (Selection m)) Full.Location + = Operation Full.OperationType (Seq (Selection m)) Full.Location + +-- | Field or inlined fragment. +data Selection m + = FieldSelection (Field m) + | FragmentSelection (Fragment m) --- | Single GraphQL field. data Field m = Field (Maybe Full.Name) Full.Name @@ -87,339 +109,217 @@ data Field m = Field (Seq (Selection m)) Full.Location --- | Contains the operation to be executed along with its root type. -data Document m = Document - (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m) - -data OperationDefinition = OperationDefinition - Full.OperationType - (Maybe Full.Name) - [Full.VariableDefinition] - [Full.Directive] - Full.SelectionSet - Full.Location - --- | Query error types. -data QueryError - = OperationNotFound Text - | OperationNameRequired - | CoercionError - | EmptyDocument - | UnsupportedRootOperation - -instance Show QueryError where - show (OperationNotFound operationName) = unwords - ["Operation", Text.unpack operationName, "couldn't be found in the document."] - show OperationNameRequired = "Missing operation name." - show CoercionError = "Coercion error." - show EmptyDocument = - "The document doesn't contain any executable operations." - show UnsupportedRootOperation = - "Root operation type couldn't be found in the schema." +data Fragment m = Fragment + (Type.CompositeType m) (Seq (Selection m)) Full.Location data Input - = Int Int32 + = Variable Type.Value + | Int Int32 | Float Double | String Text | Boolean Bool | Null - | Enum Name - | List [Type.Value] - | Object (HashMap Name Input) - | Variable Type.Value - deriving (Eq, Show) - -getOperation - :: Maybe Full.Name - -> NonEmpty OperationDefinition - -> Either QueryError OperationDefinition -getOperation Nothing (operation' :| []) = pure operation' -getOperation Nothing _ = Left OperationNameRequired -getOperation (Just operationName) operations - | Just operation' <- find matchingName operations = pure operation' - | otherwise = Left $ OperationNotFound operationName - where - matchingName (OperationDefinition _ name _ _ _ _) = - name == Just operationName - -coerceVariableValues :: Coerce.VariableValue a - => forall m - . HashMap Full.Name (Schema.Type m) - -> OperationDefinition - -> HashMap.HashMap Full.Name a - -> Either QueryError Type.Subs -coerceVariableValues types operationDefinition variableValues = - let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition - in maybe (Left CoercionError) Right - $ foldr forEach (Just HashMap.empty) variableDefinitions + | Enum Full.Name + | List [Input] + | Object (HashMap Full.Name Input) + deriving Eq + +instance Show Input where + showList = mappend . showList' + where + showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]" + show (Int integer) = show integer + show (Float float') = showFloat float' mempty + show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text + show (Boolean boolean') = show boolean' + show Null = "null" + show (Enum name) = Text.unpack name + show (List list) = show list + show (Object fields) = unwords + [ "{" + , intercalate ", " (HashMap.foldrWithKey showObject [] fields) + , "}" + ] + where + showObject key value accumulator = + concat [Text.unpack key, ": ", show value] : accumulator + show variableValue = show variableValue + +-- | Extracts operations and fragment definitions of the document. +document :: Full.Document + -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition) +document = foldr filterOperation ([], HashMap.empty) where - forEach variableDefinition coercedValues = do - let Full.VariableDefinition variableName variableTypeName defaultValue _ = - variableDefinition - let defaultValue' = constValue . Full.node <$> defaultValue - variableType <- Type.lookupInputType variableTypeName types - - Coerce.matchFieldValues - coerceVariableValue' - variableValues - variableName - variableType - defaultValue' - coercedValues - coerceVariableValue' variableType value' - = Coerce.coerceVariableValue variableType value' - >>= Coerce.coerceInputLiteral variableType - -constValue :: Full.ConstValue -> Type.Value -constValue (Full.ConstInt i) = Type.Int i -constValue (Full.ConstFloat f) = Type.Float f -constValue (Full.ConstString x) = Type.String x -constValue (Full.ConstBoolean b) = Type.Boolean b -constValue Full.ConstNull = Type.Null -constValue (Full.ConstEnum e) = Type.Enum e -constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list -constValue (Full.ConstObject o) = - Type.Object $ HashMap.fromList $ constObjectField <$> o - where - constObjectField Full.ObjectField{value = value', ..} = - (name, constValue $ Full.node value') + filterOperation (Full.ExecutableDefinition executableDefinition) accumulator + | Full.DefinitionOperation operationDefinition' <- executableDefinition = + first (operationDefinition' :) accumulator + | Full.DefinitionFragment fragmentDefinition <- executableDefinition + , Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition = + HashMap.insert fragmentName fragmentDefinition <$> accumulator + filterOperation _ accumulator = accumulator -- Type system definitions. -- | Rewrites the original syntax tree into an intermediate representation used --- for query execution. -document :: Coerce.VariableValue a - => forall m - . Type.Schema m - -> Maybe Full.Name - -> HashMap Full.Name a - -> Full.Document - -> Either QueryError (Document m) -document schema operationName subs ast = do - let referencedTypes = Schema.types schema - - (operations, fragmentTable) <- defragment ast - chosenOperation <- getOperation operationName operations - coercedValues <- coerceVariableValues referencedTypes chosenOperation subs - - let replacement = Replacement - { fragments = HashMap.empty - , fragmentDefinitions = fragmentTable - , variableValues = coercedValues - , types = referencedTypes - } - case chosenOperation of - OperationDefinition Full.Query _ _ _ _ _ -> - pure $ Document referencedTypes (Schema.query schema) - $ operation chosenOperation replacement - OperationDefinition Full.Mutation _ _ _ _ _ - | Just mutationType <- Schema.mutation schema -> - pure $ Document referencedTypes mutationType - $ operation chosenOperation replacement - OperationDefinition Full.Subscription _ _ _ _ _ - | Just subscriptionType <- Schema.subscription schema -> - pure $ Document referencedTypes subscriptionType - $ operation chosenOperation replacement - _ -> Left UnsupportedRootOperation - -defragment - :: Full.Document - -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions) -defragment ast = - let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast - nonEmptyOperations = NonEmpty.nonEmpty operations - emptyDocument = Left EmptyDocument - in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations +-- for the query execution. +transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m) +transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do + transformedSelections <- selectionSet selectionSet' + pure $ Operation operationType transformedSelections operationLocation +transform (Full.SelectionSet selectionSet' operationLocation) = do + transformedSelections <- selectionSet selectionSet' + pure $ Operation Full.Query transformedSelections operationLocation + +selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m)) +selectionSet = selectionSetOpt . NonEmpty.toList + +selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m)) +selectionSetOpt = foldM go Seq.empty where - 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 location -> - OperationDefinition type' name variables directives' selections location - Full.SelectionSet selectionSet location -> - OperationDefinition Full.Query Nothing mempty mempty selectionSet location - --- * Operation - -operation :: OperationDefinition -> Replacement m -> Operation m -operation operationDefinition replacement - = runIdentity - $ evalStateT (collectFragments >> transform operationDefinition) replacement + go accumulatedSelections currentSelection = + selection currentSelection <&> (accumulatedSelections ><) + +selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m)) +selection (Full.FieldSelection field') = + maybeToSelectionSet FieldSelection $ field field' +selection (Full.FragmentSpreadSelection fragmentSpread') = + maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread' +selection (Full.InlineFragmentSelection inlineFragment') = + either id (pure . FragmentSelection) <$> inlineFragment inlineFragment' + +maybeToSelectionSet :: Monad m + => forall a + . (a -> Selection m) + -> TransformT m (Maybe a) + -> TransformT m (Seq (Selection m)) +maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType) + +directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Definition.Directive]) +directives = fmap Type.selection . traverse directive + +inlineFragment :: Monad m + => Full.InlineFragment + -> TransformT m (Either (Seq (Selection m)) (Fragment m)) +inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location) + | Just typeCondition <- maybeCondition = do + transformedSelections <- selectionSet selectionSet' + transformedDirectives <- directives directives' + maybeFragmentType <- asks + $ Type.lookupTypeCondition typeCondition + . types + pure $ case transformedDirectives >> maybeFragmentType of + Just fragmentType -> Right + $ Fragment fragmentType transformedSelections location + Nothing -> Left Seq.empty + | otherwise = do + transformedSelections <- selectionSet selectionSet' + transformedDirectives <- directives directives' + pure $ if isJust transformedDirectives + then Left transformedSelections + else Left Seq.empty + +fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m)) +fragmentSpread (Full.FragmentSpread spreadName directives' location) = do + transformedDirectives <- directives directives' + visitedFragment <- asks $ HashSet.member spreadName . visitedFragments + possibleFragmentDefinition <- asks + $ HashMap.lookup spreadName + . fragmentDefinitions + case transformedDirectives >> possibleFragmentDefinition of + Just (Full.FragmentDefinition _ typeCondition _ selections _) + | visitedFragment -> pure Nothing + | otherwise -> do + fragmentType <- asks + $ Type.lookupTypeCondition typeCondition + . types + traverse (traverseSelections selections) fragmentType + Nothing -> pure Nothing where - transform (OperationDefinition Full.Query name _ _ sels location) = - flip (Query name) location <$> appendSelection sels - transform (OperationDefinition Full.Mutation name _ _ sels location) = - flip (Mutation name) location <$> appendSelection sels - transform (OperationDefinition Full.Subscription name _ _ sels location) = - flip (Subscription name) location <$> appendSelection sels - --- * Selection - -selection - :: Full.Selection - -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) -selection (Full.FieldSelection fieldSelection) = - maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection -selection (Full.FragmentSpreadSelection fragmentSelection) - = maybe (Left mempty) (Right . SelectionFragment) - <$> fragmentSpread fragmentSelection -selection (Full.InlineFragmentSelection fragmentSelection) = - inlineFragment fragmentSelection - -field :: Full.Field -> State (Replacement m) (Maybe (Field m)) -field (Full.Field alias name arguments' directives' selections location) = do - fieldArguments <- foldM go HashMap.empty arguments' - fieldSelections <- appendSelection selections - fieldDirectives <- Definition.selection <$> directives directives' - let field' = Field alias name fieldArguments fieldSelections location - pure $ field' <$ fieldDirectives + traverseSelections selections typeCondition = do + transformedSelections <- TransformT + $ local fragmentInserter + $ runTransformT + $ selectionSet selections + pure $ Fragment typeCondition transformedSelections location + fragmentInserter replacement@Replacement{ visitedFragments } = replacement + { visitedFragments = HashSet.insert spreadName visitedFragments } + +field :: Monad m => Full.Field -> TransformT m (Maybe (Field m)) +field (Full.Field alias' name' arguments' directives' selectionSet' location') = do + transformedSelections <- selectionSetOpt selectionSet' + transformedDirectives <- directives directives' + transformedArguments <- arguments arguments' + let transformedField = Field + alias' + name' + transformedArguments + transformedSelections + location' + pure $ transformedDirectives >> pure transformedField + +arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input)) +arguments = foldM go HashMap.empty where - go arguments (Full.Argument name' (Full.Node value' _) location') = do - objectFieldValue <- input value' - case objectFieldValue of - Just fieldValue -> - let argumentNode = Full.Node fieldValue location' - in pure $ HashMap.insert name' argumentNode arguments - Nothing -> pure arguments - -fragmentSpread - :: Full.FragmentSpread - -> State (Replacement m) (Maybe (Fragment m)) -fragmentSpread (Full.FragmentSpread name directives' _) = do - spreadDirectives <- Definition.selection <$> directives directives' - fragments' <- gets fragments - - fragmentDefinitions' <- gets fragmentDefinitions - case HashMap.lookup name fragments' of - Just definition -> lift $ pure $ definition <$ spreadDirectives - Nothing - | Just definition <- HashMap.lookup name fragmentDefinitions' -> do - fragDef <- fragmentDefinition definition - case fragDef of - Just fragment -> lift $ pure $ fragment <$ spreadDirectives - _ -> lift $ pure Nothing - | otherwise -> lift $ pure Nothing - -inlineFragment - :: Full.InlineFragment - -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) -inlineFragment (Full.InlineFragment type' directives' selections _) = do - fragmentDirectives <- Definition.selection <$> directives directives' - case fragmentDirectives of - Nothing -> pure $ Left mempty - _ -> do - fragmentSelectionSet <- appendSelection selections - - case type' of - Nothing -> pure $ Left fragmentSelectionSet - Just typeName -> do - types' <- gets types - case Type.lookupTypeCondition typeName types' of - Just typeCondition -> pure $ - selectionFragment typeCondition fragmentSelectionSet - Nothing -> pure $ Left mempty - where - selectionFragment typeName = Right - . SelectionFragment - . Fragment typeName - -appendSelection :: Traversable t - => t Full.Selection - -> State (Replacement m) (Seq (Selection m)) -appendSelection = foldM go mempty - where - go acc sel = append acc <$> selection sel - append acc (Left list) = list >< acc - append acc (Right one) = one <| acc - -directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive] -directives = traverse directive + go accumulator (Full.Argument name' valueNode argumentLocation) = do + let replaceLocation = flip Full.Node argumentLocation . Full.node + argumentValue <- fmap replaceLocation <$> node valueNode + pure $ insertIfGiven name' argumentValue accumulator + +directive :: Monad m => Full.Directive -> TransformT m Definition.Directive +directive (Full.Directive name' arguments' _) + = Definition.Directive name' + . Type.Arguments + <$> foldM go HashMap.empty arguments' where - directive (Full.Directive directiveName directiveArguments _) - = Definition.Directive directiveName . Type.Arguments - <$> foldM go HashMap.empty directiveArguments - go arguments (Full.Argument name (Full.Node value' _) _) = do - substitutedValue <- value value' - return $ HashMap.insert name substitutedValue arguments - --- * Fragment replacement - --- | Extract fragment definitions into a single 'HashMap'. -collectFragments :: State (Replacement m) () -collectFragments = do - fragDefs <- gets fragmentDefinitions - let nextValue = head $ HashMap.elems fragDefs - unless (HashMap.null fragDefs) $ do - _ <- fragmentDefinition nextValue - collectFragments - -fragmentDefinition - :: Full.FragmentDefinition - -> State (Replacement m) (Maybe (Fragment m)) -fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do - modify deleteFragmentDefinition - fragmentSelection <- appendSelection selections - types' <- gets types - - case Type.lookupTypeCondition type' types' of - Just compositeType -> do - let newValue = Fragment compositeType fragmentSelection - modify $ insertFragment newValue - lift $ pure $ Just newValue - _ -> lift $ pure Nothing + go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do + transformedValue <- directiveValue node' + pure $ HashMap.insert argumentName transformedValue accumulator + +directiveValue :: Monad m => Full.Value -> TransformT m Type.Value +directiveValue = \case + (Full.Variable name') -> asks + $ HashMap.lookupDefault Type.Null name' + . variableValues + (Full.Int integer) -> pure $ Type.Int integer + (Full.Float double) -> pure $ Type.Float double + (Full.String string) -> pure $ Type.String string + (Full.Boolean boolean) -> pure $ Type.Boolean boolean + Full.Null -> pure Type.Null + (Full.Enum enum) -> pure $ Type.Enum enum + (Full.List list) -> Type.List <$> traverse directiveNode list + (Full.Object objectFields) -> + Type.Object <$> foldM objectField HashMap.empty objectFields where - deleteFragmentDefinition replacement@Replacement{..} = - let newDefinitions = HashMap.delete name fragmentDefinitions - in replacement{ fragmentDefinitions = newDefinitions } - insertFragment newValue replacement@Replacement{..} = - let newFragments = HashMap.insert name newValue fragments - in replacement{ fragments = newFragments } - -value :: forall m. Full.Value -> State (Replacement m) Type.Value -value (Full.Variable name) = - gets (fromMaybe Type.Null . HashMap.lookup name . variableValues) -value (Full.Int int) = pure $ Type.Int int -value (Full.Float float) = pure $ Type.Float float -value (Full.String string) = pure $ Type.String string -value (Full.Boolean boolean) = pure $ Type.Boolean boolean -value Full.Null = pure Type.Null -value (Full.Enum enum) = pure $ Type.Enum enum -value (Full.List list) = Type.List <$> traverse (value . Full.node) list -value (Full.Object object) = - Type.Object . HashMap.fromList <$> traverse objectField object + directiveNode Full.Node{ node = node'} = directiveValue node' + objectField accumulator Full.ObjectField{ name, value } = do + transformedValue <- directiveNode value + pure $ HashMap.insert name transformedValue accumulator + +input :: Monad m => Full.Value -> TransformT m (Maybe Input) +input (Full.Variable name') = + asks (HashMap.lookup name' . variableValues) <&> fmap Variable +input (Full.Int integer) = pure $ Just $ Int integer +input (Full.Float double) = pure $ Just $ Float double +input (Full.String string) = pure $ Just $ String string +input (Full.Boolean boolean) = pure $ Just $ Boolean boolean +input Full.Null = pure $ Just Null +input (Full.Enum enum) = pure $ Just $ Enum enum +input (Full.List list) = Just . List + <$> traverse (fmap (fromMaybe Null) . input . Full.node) list +input (Full.Object objectFields) = Just . Object + <$> foldM objectField HashMap.empty objectFields where - objectField Full.ObjectField{value = value', ..} = - (name,) <$> value (Full.node value') - -input :: forall m. Full.Value -> State (Replacement m) (Maybe Input) -input (Full.Variable name) = - gets (fmap Variable . HashMap.lookup name . variableValues) -input (Full.Int int) = pure $ pure $ Int int -input (Full.Float float) = pure $ pure $ Float float -input (Full.String string) = pure $ pure $ String string -input (Full.Boolean boolean) = pure $ pure $ Boolean boolean -input Full.Null = pure $ pure Null -input (Full.Enum enum) = pure $ pure $ Enum enum -input (Full.List list) = pure . List <$> traverse (value . Full.node) list -input (Full.Object object) = do - objectFields <- foldM objectField HashMap.empty object - pure $ pure $ Object objectFields - where - objectField resultMap Full.ObjectField{value = value', ..} = - inputField resultMap name $ Full.node value' - -inputField :: forall m - . HashMap Full.Name Input - -> Full.Name - -> Full.Value - -> State (Replacement m) (HashMap Full.Name Input) -inputField resultMap name value' = do - objectFieldValue <- input value' - case objectFieldValue of - Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap - Nothing -> pure resultMap + objectField accumulator Full.ObjectField{..} = do + objectFieldValue <- fmap Full.node <$> node value + pure $ insertIfGiven name objectFieldValue accumulator + +insertIfGiven :: forall a + . Full.Name + -> Maybe a + -> HashMap Full.Name a + -> HashMap Full.Name a +insertIfGiven name (Just v) = HashMap.insert name v +insertIfGiven _ _ = id + +node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input)) +node Full.Node{node = node', ..} = + traverse Full.Node <$> input node' <*> pure location + diff --git a/src/Language/GraphQL/TH.hs b/src/Language/GraphQL/TH.hs new file mode 100644 index 0000000..b6bc18c --- /dev/null +++ b/src/Language/GraphQL/TH.hs @@ -0,0 +1,38 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + +-- | Template Haskell helpers. +module Language.GraphQL.TH + ( gql + ) where + +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH (Exp(..), Lit(..)) + +stripIndentation :: String -> String +stripIndentation code = reverse + $ dropNewlines + $ reverse + $ unlines + $ indent spaces <$> lines withoutLeadingNewlines + where + indent 0 xs = xs + indent count (' ' : xs) = indent (count - 1) xs + indent _ xs = xs + withoutLeadingNewlines = dropNewlines code + dropNewlines = dropWhile (== '\n') + spaces = length $ takeWhile (== ' ') withoutLeadingNewlines + +-- | Removes leading and trailing newlines. Indentation of the first line is +-- removed from each line of the string. +gql :: QuasiQuoter +gql = QuasiQuoter + { quoteExp = pure . LitE . StringL . stripIndentation + , quotePat = const + $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)" + , quoteType = const + $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)" + , quoteDec = const + $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)" + } diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 6ca77aa..1c8876a 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -1,4 +1,9 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at https://mozilla.org/MPL/2.0/. -} + {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | Types that can be used as both input and output types. module Language.GraphQL.Type.Definition @@ -20,10 +25,12 @@ module Language.GraphQL.Type.Definition import Data.Int (Int32) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.List (intercalate) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text -import Language.GraphQL.AST (Name) +import Language.GraphQL.AST (Name, escape) +import Numeric (showFloat) import Prelude hiding (id) -- | Represents accordingly typed GraphQL values. @@ -36,7 +43,27 @@ data Value | Enum Name | List [Value] -- ^ Arbitrary nested list. | Object (HashMap Name Value) - deriving (Eq, Show) + deriving Eq + +instance Show Value where + showList = mappend . showList' + where + showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]" + show (Int integer) = show integer + show (Float float') = showFloat float' mempty + show (String text) = "\"" <> Text.foldr (mappend . escape) "\"" text + show (Boolean boolean') = show boolean' + show Null = "null" + show (Enum name) = Text.unpack name + show (List list) = show list + show (Object fields) = unwords + [ "{" + , intercalate ", " (HashMap.foldrWithKey showObject [] fields) + , "}" + ] + where + showObject key value accumulator = + concat [Text.unpack key, ": ", show value] : accumulator instance IsString Value where fromString = String . fromString diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index d42599b..376ed6f 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} -- | Input types and values. diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index 0c7dd39..bc6aac4 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -6,10 +6,10 @@ module Language.GraphQL.AST.EncoderSpec import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Encoder +import Language.GraphQL.TH import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain) import Test.QuickCheck (choose, oneof, forAll) -import Text.RawString.QQ (r) -import Data.Text.Lazy (cons, toStrict, unpack) +import qualified Data.Text.Lazy as Text.Lazy spec :: Spec spec = do @@ -48,23 +48,32 @@ spec = do it "uses strings for short string values" $ value pretty (Full.String "Short text") `shouldBe` "\"Short text\"" it "uses block strings for text with new lines, with newline symbol" $ - value pretty (Full.String "Line 1\nLine 2") - `shouldBe` [r|""" - Line 1 - Line 2 -"""|] + let expected = [gql| + """ + Line 1 + Line 2 + """ + |] + actual = value pretty $ Full.String "Line 1\nLine 2" + in actual `shouldBe` expected it "uses block strings for text with new lines, with CR symbol" $ - value pretty (Full.String "Line 1\rLine 2") - `shouldBe` [r|""" - Line 1 - Line 2 -"""|] + let expected = [gql| + """ + Line 1 + Line 2 + """ + |] + actual = value pretty $ Full.String "Line 1\rLine 2" + in actual `shouldBe` expected it "uses block strings for text with new lines, with CR symbol followed by newline" $ - value pretty (Full.String "Line 1\r\nLine 2") - `shouldBe` [r|""" - Line 1 - Line 2 -"""|] + let expected = [gql| + """ + Line 1 + Line 2 + """ + |] + actual = value pretty $ Full.String "Line 1\r\nLine 2" + in actual `shouldBe` expected it "encodes as one line string if has escaped symbols" $ do let genNotAllowedSymbol = oneof @@ -76,48 +85,74 @@ spec = do forAll genNotAllowedSymbol $ \x -> do let - rawValue = "Short \n" <> cons x "text" - encoded = value pretty (Full.String $ toStrict rawValue) - shouldStartWith (unpack encoded) "\"" - shouldEndWith (unpack encoded) "\"" - shouldNotContain (unpack encoded) "\"\"\"" - - it "Hello world" $ value pretty (Full.String "Hello,\n World!\n\nYours,\n GraphQL.") - `shouldBe` [r|""" - Hello, - World! - - Yours, - GraphQL. -"""|] - - it "has only newlines" $ value pretty (Full.String "\n") `shouldBe` [r|""" - - -"""|] + rawValue = "Short \n" <> Text.Lazy.cons x "text" + encoded = value pretty + $ Full.String $ Text.Lazy.toStrict rawValue + shouldStartWith (Text.Lazy.unpack encoded) "\"" + shouldEndWith (Text.Lazy.unpack encoded) "\"" + shouldNotContain (Text.Lazy.unpack encoded) "\"\"\"" + + it "Hello world" $ + let actual = value pretty + $ Full.String "Hello,\n World!\n\nYours,\n GraphQL." + expected = [gql| + """ + Hello, + World! + + Yours, + GraphQL. + """ + |] + in actual `shouldBe` expected + + it "has only newlines" $ + let actual = value pretty $ Full.String "\n" + expected = [gql| + """ + + + """ + |] + in actual `shouldBe` expected it "has newlines and one symbol at the begining" $ - value pretty (Full.String "a\n\n") `shouldBe` [r|""" - a + let actual = value pretty $ Full.String "a\n\n" + expected = [gql| + """ + a -"""|] + """|] + in actual `shouldBe` expected it "has newlines and one symbol at the end" $ - value pretty (Full.String "\n\na") `shouldBe` [r|""" + let actual = value pretty $ Full.String "\n\na" + expected = [gql| + """ - a -"""|] + a + """ + |] + in actual `shouldBe` expected it "has newlines and one symbol in the middle" $ - value pretty (Full.String "\na\n") `shouldBe` [r|""" - - a - -"""|] - it "skip trailing whitespaces" $ value pretty (Full.String " Short\ntext ") - `shouldBe` [r|""" - Short - text -"""|] + let actual = value pretty $ Full.String "\na\n" + expected = [gql| + """ + + a + + """ + |] + in actual `shouldBe` expected + it "skip trailing whitespaces" $ + let actual = value pretty $ Full.String " Short\ntext " + expected = [gql| + """ + Short + text + """ + |] + in actual `shouldBe` expected describe "definition" $ it "indents block strings in arguments" $ @@ -128,10 +163,13 @@ spec = do fieldSelection = pure $ Full.FieldSelection field operation = Full.DefinitionOperation $ Full.SelectionSet fieldSelection location - in definition pretty operation `shouldBe` [r|{ - field(message: """ - line1 - line2 - """) -} -|] + expected = Text.Lazy.snoc [gql| + { + field(message: """ + line1 + line2 + """) + } + |] '\n' + actual = definition pretty operation + in actual `shouldBe` expected diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs index c4fae45..e22c6b0 100644 --- a/tests/Language/GraphQL/AST/LexerSpec.hs +++ b/tests/Language/GraphQL/AST/LexerSpec.hs @@ -7,10 +7,10 @@ module Language.GraphQL.AST.LexerSpec import Data.Text (Text) import Data.Void (Void) import Language.GraphQL.AST.Lexer +import Language.GraphQL.TH import Test.Hspec (Spec, context, describe, it) import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (ParseErrorBundle, parse) -import Text.RawString.QQ (r) spec :: Spec spec = describe "Lexer" $ do @@ -19,32 +19,32 @@ spec = describe "Lexer" $ do parse unicodeBOM "" `shouldSucceedOn` "\xfeff" it "lexes strings" $ do - parse string "" [r|"simple"|] `shouldParse` "simple" - parse string "" [r|" white space "|] `shouldParse` " white space " - parse string "" [r|"quote \""|] `shouldParse` [r|quote "|] - parse string "" [r|"escaped \n"|] `shouldParse` "escaped \n" - parse string "" [r|"slashes \\ \/"|] `shouldParse` [r|slashes \ /|] - parse string "" [r|"unicode \u1234\u5678\u90AB\uCDEF"|] + parse string "" [gql|"simple"|] `shouldParse` "simple" + parse string "" [gql|" white space "|] `shouldParse` " white space " + parse string "" [gql|"quote \""|] `shouldParse` [gql|quote "|] + parse string "" [gql|"escaped \n"|] `shouldParse` "escaped \n" + parse string "" [gql|"slashes \\ \/"|] `shouldParse` [gql|slashes \ /|] + parse string "" [gql|"unicode \u1234\u5678\u90AB\uCDEF"|] `shouldParse` "unicode ሴ噸邫췯" it "lexes block string" $ do - parse blockString "" [r|"""simple"""|] `shouldParse` "simple" - parse blockString "" [r|""" white space """|] + parse blockString "" [gql|"""simple"""|] `shouldParse` "simple" + parse blockString "" [gql|""" white space """|] `shouldParse` " white space " - parse blockString "" [r|"""contains " quote"""|] - `shouldParse` [r|contains " quote|] - parse blockString "" [r|"""contains \""" triplequote"""|] - `shouldParse` [r|contains """ triplequote|] + parse blockString "" [gql|"""contains " quote"""|] + `shouldParse` [gql|contains " quote|] + parse blockString "" [gql|"""contains \""" triplequote"""|] + `shouldParse` [gql|contains """ triplequote|] parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline" parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\"" `shouldParse` "multi\nline\nnormalized" parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\"" `shouldParse` "multi\nline\nnormalized" - parse blockString "" [r|"""unescaped \n\r\b\t\f\u1234"""|] - `shouldParse` [r|unescaped \n\r\b\t\f\u1234|] - parse blockString "" [r|"""slashes \\ \/"""|] - `shouldParse` [r|slashes \\ \/|] - parse blockString "" [r|""" + parse blockString "" [gql|"""unescaped \n\r\b\t\f\u1234"""|] + `shouldParse` [gql|unescaped \n\r\b\t\f\u1234|] + parse blockString "" [gql|"""slashes \\ \/"""|] + `shouldParse` [gql|slashes \\ \/|] + parse blockString "" [gql|""" spans multiple @@ -84,7 +84,7 @@ spec = describe "Lexer" $ do context "Implementation tests" $ do it "lexes empty block strings" $ - parse blockString "" [r|""""""|] `shouldParse` "" + parse blockString "" [gql|""""""|] `shouldParse` "" it "lexes ampersand" $ parse amp "" "&" `shouldParse` "&" it "lexes schema extensions" $ diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index a47fc11..702beab 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -8,10 +8,10 @@ import Data.List.NonEmpty (NonEmpty(..)) import Language.GraphQL.AST.Document import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc import Language.GraphQL.AST.Parser +import Language.GraphQL.TH import Test.Hspec (Spec, describe, it) import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (parse) -import Text.RawString.QQ (r) spec :: Spec spec = describe "Parser" $ do @@ -19,74 +19,74 @@ spec = describe "Parser" $ do parse document "" `shouldSucceedOn` "\xfeff{foo}" it "accepts block strings as argument" $ - parse document "" `shouldSucceedOn` [r|{ + parse document "" `shouldSucceedOn` [gql|{ hello(text: """Argument""") }|] it "accepts strings as argument" $ - parse document "" `shouldSucceedOn` [r|{ + parse document "" `shouldSucceedOn` [gql|{ hello(text: "Argument") }|] it "accepts two required arguments" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| mutation auth($username: String!, $password: String!){ test }|] it "accepts two string arguments" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| mutation auth{ test(username: "username", password: "password") }|] it "accepts two block string arguments" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| mutation auth{ test(username: """username""", password: """password""") }|] it "parses minimal schema definition" $ - parse document "" `shouldSucceedOn` [r|schema { query: Query }|] + parse document "" `shouldSucceedOn` [gql|schema { query: Query }|] it "parses minimal scalar definition" $ - parse document "" `shouldSucceedOn` [r|scalar Time|] + parse document "" `shouldSucceedOn` [gql|scalar Time|] it "parses ImplementsInterfaces" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| type Person implements NamedEntity & ValuedEntity { name: String } |] it "parses a type without ImplementsInterfaces" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| type Person { name: String } |] it "parses ArgumentsDefinition in an ObjectDefinition" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| type Person { name(first: String, last: String): String } |] it "parses minimal union type definition" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| union SearchResult = Photo | Person |] it "parses minimal interface type definition" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| interface NamedEntity { name: String } |] it "parses minimal enum type definition" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| enum Direction { NORTH EAST @@ -96,7 +96,7 @@ spec = describe "Parser" $ do |] it "parses minimal enum type definition" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| enum Direction { NORTH EAST @@ -106,7 +106,7 @@ spec = describe "Parser" $ do |] it "parses minimal input object type definition" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| input Point2D { x: Float y: Float @@ -114,7 +114,7 @@ spec = describe "Parser" $ do |] it "parses minimal input enum definition with an optional pipe" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| directive @example on | FIELD | FRAGMENT_SPREAD @@ -131,15 +131,15 @@ spec = describe "Parser" $ do example1 = directive "example1" (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition) - (Location {line = 2, column = 17}) + (Location {line = 1, column = 1}) example2 = directive "example2" (DirLoc.ExecutableDirectiveLocation DirLoc.Field) - (Location {line = 3, column = 17}) + (Location {line = 2, column = 1}) testSchemaExtension = example1 :| [ example2 ] - query = [r| - directive @example1 on FIELD_DEFINITION - directive @example2 on FIELD + query = [gql| + directive @example1 on FIELD_DEFINITION + directive @example2 on FIELD |] in parse document "" query `shouldParse` testSchemaExtension @@ -167,16 +167,16 @@ spec = describe "Parser" $ do $ Node (ConstList []) $ Location {line = 1, column = 33})] (Location {line = 1, column = 1}) - query = [r|directive @test(foo: [String] = []) on FIELD_DEFINITION|] + query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|] in parse document "" query `shouldParse` (defn :| [ ]) it "parses schema extension with a new directive" $ - parse document "" `shouldSucceedOn`[r| + parse document "" `shouldSucceedOn`[gql| extend schema @newDirective |] it "parses schema extension with an operation type definition" $ - parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|] + parse document "" `shouldSucceedOn` [gql|extend schema { query: Query }|] it "parses schema extension with an operation type and directive" $ let newDirective = Directive "newDirective" [] $ Location 1 15 @@ -185,25 +185,25 @@ spec = describe "Parser" $ do $ OperationTypeDefinition Query "Query" :| [] testSchemaExtension = TypeSystemExtension schemaExtension $ Location 1 1 - query = [r|extend schema @newDirective { query: Query }|] + query = [gql|extend schema @newDirective { query: Query }|] in parse document "" query `shouldParse` (testSchemaExtension :| []) it "parses an object extension" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| extend type Story { isHiddenLocally: Boolean } |] it "rejects variables in DefaultValue" $ - parse document "" `shouldFailOn` [r| + parse document "" `shouldFailOn` [gql| query ($book: String = "Zarathustra", $author: String = $book) { title } |] it "parses documents beginning with a comment" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| """ Query """ @@ -213,7 +213,7 @@ spec = describe "Parser" $ do |] it "parses subscriptions" $ - parse document "" `shouldSucceedOn` [r| + parse document "" `shouldSucceedOn` [gql| subscription NewMessages { newMessage(roomId: 123) { sender diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index d14eb9d..6723524 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -21,6 +21,7 @@ import Language.GraphQL.AST (Document, Location(..), Name) import Language.GraphQL.AST.Parser (document) import Language.GraphQL.Error import Language.GraphQL.Execute (execute) +import Language.GraphQL.TH import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Type import qualified Language.GraphQL.Type.In as In @@ -28,7 +29,6 @@ import qualified Language.GraphQL.Type.Out as Out import Prelude hiding (id) import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse) -import Text.RawString.QQ (r) data PhilosopherException = PhilosopherException deriving Show @@ -54,18 +54,23 @@ queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList [ ("philosopher", ValueResolver philosopherField philosopherResolver) , ("genres", ValueResolver genresField genresResolver) + , ("count", ValueResolver countField countResolver) ] where philosopherField = - Out.Field Nothing (Out.NonNullObjectType philosopherType) + Out.Field Nothing (Out.NamedObjectType philosopherType) $ HashMap.singleton "id" $ In.Argument Nothing (In.NamedScalarType id) Nothing philosopherResolver = pure $ Object mempty genresField = - let fieldType = Out.ListType $ Out.NonNullScalarType string - in Out.Field Nothing fieldType HashMap.empty + let fieldType = Out.ListType $ Out.NonNullScalarType string + in Out.Field Nothing fieldType HashMap.empty genresResolver :: Resolve (Either SomeException) genresResolver = throwM PhilosopherException + countField = + let fieldType = Out.NonNullScalarType int + in Out.Field Nothing fieldType HashMap.empty + countResolver = pure "" musicType :: Out.ObjectType (Either SomeException) musicType = Out.ObjectType "Music" Nothing [] @@ -101,6 +106,7 @@ philosopherType = Out.ObjectType "Philosopher" Nothing [] , ("interest", ValueResolver interestField interestResolver) , ("majorWork", ValueResolver majorWorkField majorWorkResolver) , ("century", ValueResolver centuryField centuryResolver) + , ("firstLanguage", ValueResolver firstLanguageField firstLanguageResolver) ] firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty @@ -126,6 +132,9 @@ philosopherType = Out.ObjectType "Philosopher" Nothing [] centuryField = Out.Field Nothing (Out.NonNullScalarType int) HashMap.empty centuryResolver = pure $ Float 18.5 + firstLanguageField + = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + firstLanguageResolver = pure Null workType :: Out.InterfaceType (Either SomeException) workType = Out.InterfaceType "Work" Nothing [] @@ -191,7 +200,7 @@ spec :: Spec spec = describe "execute" $ do it "rejects recursive fragments" $ - let sourceQuery = [r| + let sourceQuery = [gql| { ...cyclicFragment } @@ -230,14 +239,13 @@ spec = it "errors on invalid output enum values" $ let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "school" .= Aeson.Null - ] + [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error - { message = "Enum value completion failed." + { message = + "Value completion error. Expected type !School, found: EXISTENTIALISM." , locations = [Location 1 17] - , path = [] + , path = [Segment "philosopher", Segment "school"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' @@ -246,14 +254,13 @@ spec = it "gives location information for non-null unions" $ let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "interest" .= Aeson.Null - ] + [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error - { message = "Union value completion failed." + { message = + "Value completion error. Expected type !Interest, found: { instrument: \"piano\" }." , locations = [Location 1 17] - , path = [] + , path = [Segment "philosopher", Segment "interest"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' @@ -262,14 +269,14 @@ spec = it "gives location information for invalid interfaces" $ let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "majorWork" .= Aeson.Null - ] + [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error - { message = "Interface value completion failed." + { message + = "Value completion error. Expected type !Work, found:\ + \ { title: \"Also sprach Zarathustra: Ein Buch f\252r Alle und Keinen\" }." , locations = [Location 1 17] - , path = [] + , path = [Segment "philosopher", Segment "majorWork"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' @@ -281,9 +288,10 @@ spec = [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error - { message = "Argument coercing failed." + { message = + "Argument \"id\" has invalid type. Expected type ID, found: True." , locations = [Location 1 15] - , path = [] + , path = [Segment "philosopher"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' @@ -292,14 +300,12 @@ spec = it "gives location information for failed result coercion" $ let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "century" .= Aeson.Null - ] + [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error - { message = "Result coercion failed." + { message = "Unable to coerce result to !Int." , locations = [Location 1 26] - , path = [] + , path = [Segment "philosopher", Segment "century"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' @@ -313,13 +319,38 @@ spec = executionErrors = pure $ Error { message = "PhilosopherException" , locations = [Location 1 3] - , path = [] + , path = [Segment "genres"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' $ parse document "" "{ genres }" in actual `shouldBe` expected + it "sets data to null if a root field isn't nullable" $ + let executionErrors = pure $ Error + { message = "Unable to coerce result to !Int." + , locations = [Location 1 3] + , path = [Segment "count"] + } + expected = Response Aeson.Null executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ count }" + in actual `shouldBe` expected + + it "detects nullability errors" $ + let data'' = Aeson.object + [ "philosopher" .= Aeson.Null + ] + executionErrors = pure $ Error + { message = "Value completion error. Expected type !String, found: null." + , locations = [Location 1 26] + , path = [Segment "philosopher", Segment "firstLanguage"] + } + expected = Response data'' executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }" + in actual `shouldBe` expected + context "Subscription" $ it "subscribes" $ let data'' = Aeson.object diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs index f75aef6..7a5f4cc 100644 --- a/tests/Language/GraphQL/Validate/RulesSpec.hs +++ b/tests/Language/GraphQL/Validate/RulesSpec.hs @@ -13,13 +13,13 @@ import Data.Foldable (toList) import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Language.GraphQL.AST as AST +import Language.GraphQL.TH import Language.GraphQL.Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Validate import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Text.Megaparsec (parse, errorBundlePretty) -import Text.RawString.QQ (r) petSchema :: Schema IO petSchema = schema queryType Nothing (Just subscriptionType) mempty @@ -163,7 +163,7 @@ spec = describe "document" $ do context "executableDefinitionsRule" $ it "rejects type definitions" $ - let queryString = [r| + let queryString = [gql| query getDogName { dog { name @@ -179,13 +179,13 @@ spec = { message = "Definition must be OperationDefinition or \ \FragmentDefinition." - , locations = [AST.Location 9 19] + , locations = [AST.Location 8 1] } in validate queryString `shouldContain` [expected] context "singleFieldSubscriptionsRule" $ do it "rejects multiple subscription root fields" $ - let queryString = [r| + let queryString = [gql| subscription sub { newMessage { body @@ -198,12 +198,12 @@ spec = { message = "Subscription \"sub\" must select only one top \ \level field." - , locations = [AST.Location 2 19] + , locations = [AST.Location 1 1] } in validate queryString `shouldContain` [expected] it "rejects multiple subscription root fields coming from a fragment" $ - let queryString = [r| + let queryString = [gql| subscription sub { ...multipleSubscriptions } @@ -220,12 +220,12 @@ spec = { message = "Subscription \"sub\" must select only one top \ \level field." - , locations = [AST.Location 2 19] + , locations = [AST.Location 1 1] } in validate queryString `shouldContain` [expected] it "finds corresponding subscription fragment" $ - let queryString = [r| + let queryString = [gql| subscription sub { ...anotherSubscription ...multipleSubscriptions @@ -249,13 +249,13 @@ spec = { message = "Subscription \"sub\" must select only one top \ \level field." - , locations = [AST.Location 2 19] + , locations = [AST.Location 1 1] } in validate queryString `shouldBe` [expected] context "loneAnonymousOperationRule" $ it "rejects multiple anonymous operations" $ - let queryString = [r| + let queryString = [gql| { dog { name @@ -274,13 +274,13 @@ spec = { message = "This anonymous operation must be the only defined \ \operation." - , locations = [AST.Location 2 19] + , locations = [AST.Location 1 1] } in validate queryString `shouldBe` [expected] context "uniqueOperationNamesRule" $ it "rejects operations with the same name" $ - let queryString = [r| + let queryString = [gql| query dogOperation { dog { name @@ -297,13 +297,13 @@ spec = { message = "There can be only one operation named \ \\"dogOperation\"." - , locations = [AST.Location 2 19, AST.Location 8 19] + , locations = [AST.Location 1 1, AST.Location 7 1] } in validate queryString `shouldBe` [expected] context "uniqueFragmentNamesRule" $ it "rejects fragments with the same name" $ - let queryString = [r| + let queryString = [gql| { dog { ...fragmentOne @@ -324,13 +324,13 @@ spec = { message = "There can be only one fragment named \ \\"fragmentOne\"." - , locations = [AST.Location 8 19, AST.Location 12 19] + , locations = [AST.Location 7 1, AST.Location 11 1] } in validate queryString `shouldBe` [expected] context "fragmentSpreadTargetDefinedRule" $ it "rejects the fragment spread without a target" $ - let queryString = [r| + let queryString = [gql| { dog { ...undefinedFragment @@ -341,13 +341,13 @@ spec = { message = "Fragment target \"undefinedFragment\" is \ \undefined." - , locations = [AST.Location 4 23] + , locations = [AST.Location 3 5] } in validate queryString `shouldBe` [expected] context "fragmentSpreadTypeExistenceRule" $ do it "rejects fragment spreads without an unknown target type" $ - let queryString = [r| + let queryString = [gql| { dog { ...notOnExistingType @@ -362,12 +362,12 @@ spec = "Fragment \"notOnExistingType\" is specified on \ \type \"NotInSchema\" which doesn't exist in the \ \schema." - , locations = [AST.Location 4 23] + , locations = [AST.Location 3 5] } in validate queryString `shouldBe` [expected] it "rejects inline fragments without a target" $ - let queryString = [r| + let queryString = [gql| { ... on NotInSchema { name @@ -378,13 +378,13 @@ spec = { message = "Inline fragment is specified on type \ \\"NotInSchema\" which doesn't exist in the schema." - , locations = [AST.Location 3 21] + , locations = [AST.Location 2 3] } in validate queryString `shouldBe` [expected] context "fragmentsOnCompositeTypesRule" $ do it "rejects fragments on scalar types" $ - let queryString = [r| + let queryString = [gql| { dog { ...fragOnScalar @@ -398,12 +398,12 @@ spec = { message = "Fragment cannot condition on non composite type \ \\"Int\"." - , locations = [AST.Location 7 19] + , locations = [AST.Location 6 1] } in validate queryString `shouldContain` [expected] it "rejects inline fragments on scalar types" $ - let queryString = [r| + let queryString = [gql| { ... on Boolean { name @@ -414,13 +414,13 @@ spec = { message = "Fragment cannot condition on non composite type \ \\"Boolean\"." - , locations = [AST.Location 3 21] + , locations = [AST.Location 2 3] } in validate queryString `shouldContain` [expected] context "noUnusedFragmentsRule" $ it "rejects unused fragments" $ - let queryString = [r| + let queryString = [gql| fragment nameFragment on Dog { # unused name } @@ -434,13 +434,13 @@ spec = expected = Error { message = "Fragment \"nameFragment\" is never used." - , locations = [AST.Location 2 19] + , locations = [AST.Location 1 1] } in validate queryString `shouldBe` [expected] context "noFragmentCyclesRule" $ it "rejects spreads that form cycles" $ - let queryString = [r| + let queryString = [gql| { dog { ...nameFragment @@ -460,20 +460,20 @@ spec = "Cannot spread fragment \"barkVolumeFragment\" \ \within itself (via barkVolumeFragment -> \ \nameFragment -> barkVolumeFragment)." - , locations = [AST.Location 11 19] + , locations = [AST.Location 10 1] } error2 = Error { message = "Cannot spread fragment \"nameFragment\" within \ \itself (via nameFragment -> barkVolumeFragment -> \ \nameFragment)." - , locations = [AST.Location 7 19] + , locations = [AST.Location 6 1] } in validate queryString `shouldBe` [error1, error2] context "uniqueArgumentNamesRule" $ it "rejects duplicate field arguments" $ - let queryString = [r| + let queryString = [gql| { dog { isHousetrained(atOtherHomes: true, atOtherHomes: true) @@ -484,13 +484,13 @@ spec = { message = "There can be only one argument named \ \\"atOtherHomes\"." - , locations = [AST.Location 4 38, AST.Location 4 58] + , locations = [AST.Location 3 20, AST.Location 3 40] } in validate queryString `shouldBe` [expected] context "uniqueDirectiveNamesRule" $ it "rejects more than one directive per location" $ - let queryString = [r| + let queryString = [gql| query ($foo: Boolean = true, $bar: Boolean = false) { dog @skip(if: $foo) @skip(if: $bar) { name @@ -500,13 +500,13 @@ spec = expected = Error { message = "There can be only one directive named \"skip\"." - , locations = [AST.Location 3 25, AST.Location 3 41] + , locations = [AST.Location 2 7, AST.Location 2 23] } in validate queryString `shouldBe` [expected] context "uniqueVariableNamesRule" $ it "rejects duplicate variables" $ - let queryString = [r| + let queryString = [gql| query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) { dog { isHousetrained(atOtherHomes: $atOtherHomes) @@ -517,13 +517,13 @@ spec = { message = "There can be only one variable named \ \\"atOtherHomes\"." - , locations = [AST.Location 2 43, AST.Location 2 67] + , locations = [AST.Location 1 25, AST.Location 1 49] } in validate queryString `shouldBe` [expected] context "variablesAreInputTypesRule" $ it "rejects non-input types as variables" $ - let queryString = [r| + let queryString = [gql| query takesDogBang($dog: Dog!) { dog { isHousetrained(atOtherHomes: $dog) @@ -534,13 +534,13 @@ spec = { message = "Variable \"$dog\" cannot be non-input type \ \\"Dog\"." - , locations = [AST.Location 2 38] + , locations = [AST.Location 1 20] } in validate queryString `shouldContain` [expected] context "noUndefinedVariablesRule" $ it "rejects undefined variables" $ - let queryString = [r| + let queryString = [gql| query variableIsNotDefinedUsedInSingleFragment { dog { ...isHousetrainedFragment @@ -556,13 +556,13 @@ spec = "Variable \"$atOtherHomes\" is not defined by \ \operation \ \\"variableIsNotDefinedUsedInSingleFragment\"." - , locations = [AST.Location 9 50] + , locations = [AST.Location 8 32] } in validate queryString `shouldBe` [expected] context "noUnusedVariablesRule" $ it "rejects unused variables" $ - let queryString = [r| + let queryString = [gql| query variableUnused($atOtherHomes: Boolean) { dog { isHousetrained @@ -573,13 +573,13 @@ spec = { message = "Variable \"$atOtherHomes\" is never used in \ \operation \"variableUnused\"." - , locations = [AST.Location 2 40] + , locations = [AST.Location 1 22] } in validate queryString `shouldBe` [expected] context "uniqueInputFieldNamesRule" $ it "rejects duplicate fields in input objects" $ - let queryString = [r| + let queryString = [gql| { findDog(complex: { name: "Fido", name: "Jack" }) { name @@ -589,13 +589,13 @@ spec = expected = Error { message = "There can be only one input field named \"name\"." - , locations = [AST.Location 3 40, AST.Location 3 54] + , locations = [AST.Location 2 22, AST.Location 2 36] } in validate queryString `shouldBe` [expected] context "fieldsOnCorrectTypeRule" $ it "rejects undefined fields" $ - let queryString = [r| + let queryString = [gql| { dog { meowVolume @@ -605,13 +605,13 @@ spec = expected = Error { message = "Cannot query field \"meowVolume\" on type \"Dog\"." - , locations = [AST.Location 4 23] + , locations = [AST.Location 3 5] } in validate queryString `shouldBe` [expected] context "scalarLeafsRule" $ it "rejects scalar fields with not empty selection set" $ - let queryString = [r| + let queryString = [gql| { dog { barkVolume { @@ -624,13 +624,13 @@ spec = { message = "Field \"barkVolume\" must not have a selection \ \since type \"Int\" has no subfields." - , locations = [AST.Location 4 23] + , locations = [AST.Location 3 5] } in validate queryString `shouldBe` [expected] context "knownArgumentNamesRule" $ do it "rejects field arguments missing in the type" $ - let queryString = [r| + let queryString = [gql| { dog { doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT) @@ -641,12 +641,12 @@ spec = { message = "Unknown argument \"command\" on field \ \\"Dog.doesKnowCommand\"." - , locations = [AST.Location 4 39] + , locations = [AST.Location 3 21] } in validate queryString `shouldBe` [expected] it "rejects directive arguments missing in the definition" $ - let queryString = [r| + let queryString = [gql| { dog { isHousetrained(atOtherHomes: true) @include(unless: false, if: true) @@ -657,13 +657,13 @@ spec = { message = "Unknown argument \"unless\" on directive \ \\"@include\"." - , locations = [AST.Location 4 67] + , locations = [AST.Location 3 49] } in validate queryString `shouldBe` [expected] context "knownDirectiveNamesRule" $ it "rejects undefined directives" $ - let queryString = [r| + let queryString = [gql| { dog { isHousetrained(atOtherHomes: true) @ignore(if: true) @@ -672,13 +672,13 @@ spec = |] expected = Error { message = "Unknown directive \"@ignore\"." - , locations = [AST.Location 4 58] + , locations = [AST.Location 3 40] } in validate queryString `shouldBe` [expected] context "knownInputFieldNamesRule" $ it "rejects undefined input object fields" $ - let queryString = [r| + let queryString = [gql| { findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) { name @@ -689,13 +689,13 @@ spec = { message = "Field \"favoriteCookieFlavor\" is not defined \ \by type \"DogData\"." - , locations = [AST.Location 3 40] + , locations = [AST.Location 2 22] } in validate queryString `shouldBe` [expected] context "directivesInValidLocationsRule" $ it "rejects directives in invalid locations" $ - let queryString = [r| + let queryString = [gql| query @skip(if: $foo) { dog { name @@ -705,13 +705,13 @@ spec = expected = Error { message = "Directive \"@skip\" may not be used on QUERY." - , locations = [AST.Location 2 25] + , locations = [AST.Location 1 7] } in validate queryString `shouldBe` [expected] context "overlappingFieldsCanBeMergedRule" $ do it "fails to merge fields of mismatching types" $ - let queryString = [r| + let queryString = [gql| { dog { name: nickname @@ -725,12 +725,12 @@ spec = \\"name\" are different fields. Use different \ \aliases on the fields to fetch both if this was \ \intentional." - , locations = [AST.Location 4 23, AST.Location 5 23] + , locations = [AST.Location 3 5, AST.Location 4 5] } in validate queryString `shouldBe` [expected] it "fails if the arguments of the same field don't match" $ - let queryString = [r| + let queryString = [gql| { dog { doesKnowCommand(dogCommand: SIT) @@ -744,12 +744,12 @@ spec = \have different arguments. Use different aliases \ \on the fields to fetch both if this was \ \intentional." - , locations = [AST.Location 4 23, AST.Location 5 23] + , locations = [AST.Location 3 5, AST.Location 4 5] } in validate queryString `shouldBe` [expected] it "fails to merge same-named field and alias" $ - let queryString = [r| + let queryString = [gql| { dog { doesKnowCommand(dogCommand: SIT) @@ -763,12 +763,12 @@ spec = \\"doesKnowCommand\" and \"isHousetrained\" are \ \different fields. Use different aliases on the \ \fields to fetch both if this was intentional." - , locations = [AST.Location 4 23, AST.Location 5 23] + , locations = [AST.Location 3 5, AST.Location 4 5] } in validate queryString `shouldBe` [expected] it "looks for fields after a successfully merged field pair" $ - let queryString = [r| + let queryString = [gql| { dog { name @@ -786,13 +786,13 @@ spec = \\"doesKnowCommand\" and \"isHousetrained\" are \ \different fields. Use different aliases on the \ \fields to fetch both if this was intentional." - , locations = [AST.Location 5 23, AST.Location 9 23] + , locations = [AST.Location 4 5, AST.Location 8 5] } in validate queryString `shouldBe` [expected] context "possibleFragmentSpreadsRule" $ do it "rejects object inline spreads outside object scope" $ - let queryString = [r| + let queryString = [gql| { dog { ... on Cat { @@ -805,12 +805,12 @@ spec = { message = "Fragment cannot be spread here as objects of type \ \\"Dog\" can never be of type \"Cat\"." - , locations = [AST.Location 4 23] + , locations = [AST.Location 3 5] } in validate queryString `shouldBe` [expected] it "rejects object named spreads outside object scope" $ - let queryString = [r| + let queryString = [gql| { dog { ... catInDogFragmentInvalid @@ -826,13 +826,13 @@ spec = "Fragment \"catInDogFragmentInvalid\" cannot be \ \spread here as objects of type \"Dog\" can never \ \be of type \"Cat\"." - , locations = [AST.Location 4 23] + , locations = [AST.Location 3 5] } in validate queryString `shouldBe` [expected] context "providedRequiredInputFieldsRule" $ it "rejects missing required input fields" $ - let queryString = [r| + let queryString = [gql| { findDog(complex: { name: null }) { name @@ -843,13 +843,13 @@ spec = { message = "Input field \"name\" of type \"DogData\" is \ \required, but it was not provided." - , locations = [AST.Location 3 38] + , locations = [AST.Location 2 20] } in validate queryString `shouldBe` [expected] context "providedRequiredArgumentsRule" $ do it "checks for (non-)nullable arguments" $ - let queryString = [r| + let queryString = [gql| { dog { doesKnowCommand(dogCommand: null) @@ -861,13 +861,13 @@ spec = "Field \"doesKnowCommand\" argument \"dogCommand\" \ \of type \"DogCommand\" is required, but it was \ \not provided." - , locations = [AST.Location 4 23] + , locations = [AST.Location 3 5] } in validate queryString `shouldBe` [expected] context "variablesInAllowedPositionRule" $ do it "rejects wrongly typed variable arguments" $ - let queryString = [r| + let queryString = [gql| query dogCommandArgQuery($dogCommandArg: DogCommand) { dog { doesKnowCommand(dogCommand: $dogCommandArg) @@ -879,12 +879,12 @@ spec = "Variable \"$dogCommandArg\" of type \ \\"DogCommand\" used in position expecting type \ \\"!DogCommand\"." - , locations = [AST.Location 2 44] + , locations = [AST.Location 1 26] } in validate queryString `shouldBe` [expected] it "rejects wrongly typed variable arguments" $ - let queryString = [r| + let queryString = [gql| query intCannotGoIntoBoolean($intArg: Int) { dog { isHousetrained(atOtherHomes: $intArg) @@ -895,13 +895,13 @@ spec = { message = "Variable \"$intArg\" of type \"Int\" used in \ \position expecting type \"Boolean\"." - , locations = [AST.Location 2 48] + , locations = [AST.Location 1 30] } in validate queryString `shouldBe` [expected] context "valuesOfCorrectTypeRule" $ do it "rejects values of incorrect types" $ - let queryString = [r| + let queryString = [gql| { dog { isHousetrained(atOtherHomes: 3) @@ -911,12 +911,12 @@ spec = expected = Error { message = "Value 3 cannot be coerced to type \"Boolean\"." - , locations = [AST.Location 4 52] + , locations = [AST.Location 3 34] } in validate queryString `shouldBe` [expected] it "uses the location of a single list value" $ - let queryString = [r| + let queryString = [gql| { cat { doesKnowCommands(catCommands: [3]) @@ -926,12 +926,12 @@ spec = expected = Error { message = "Value 3 cannot be coerced to type \"!CatCommand\"." - , locations = [AST.Location 4 54] + , locations = [AST.Location 3 36] } in validate queryString `shouldBe` [expected] it "validates input object properties once" $ - let queryString = [r| + let queryString = [gql| { findDog(complex: { name: 3 }) { name @@ -941,12 +941,12 @@ spec = expected = Error { message = "Value 3 cannot be coerced to type \"!String\"." - , locations = [AST.Location 3 46] + , locations = [AST.Location 2 28] } in validate queryString `shouldBe` [expected] it "checks for required list members" $ - let queryString = [r| + let queryString = [gql| { cat { doesKnowCommands(catCommands: [null]) @@ -957,6 +957,6 @@ spec = { message = "List of non-null values of type \"CatCommand\" \ \cannot contain null values." - , locations = [AST.Location 4 54] + , locations = [AST.Location 3 36] } in validate queryString `shouldBe` [expected] diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 2d586f6..50caa5b 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -12,11 +12,11 @@ import Data.Aeson (object, (.=)) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap import Language.GraphQL +import Language.GraphQL.TH import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out import Test.Hspec (Spec, describe, it) import Test.Hspec.GraphQL -import Text.RawString.QQ (r) experimentalResolver :: Schema IO experimentalResolver = schema queryType Nothing Nothing mempty @@ -33,7 +33,7 @@ spec :: Spec spec = describe "Directive executor" $ do it "should be able to @skip fields" $ do - let sourceQuery = [r| + let sourceQuery = [gql| { experimentalField @skip(if: true) } @@ -43,7 +43,7 @@ spec = actual `shouldResolveTo` emptyObject it "should not skip fields if @skip is false" $ do - let sourceQuery = [r| + let sourceQuery = [gql| { experimentalField @skip(if: false) } @@ -56,7 +56,7 @@ spec = actual `shouldResolveTo` expected it "should skip fields if @include is false" $ do - let sourceQuery = [r| + let sourceQuery = [gql| { experimentalField @include(if: false) } @@ -66,7 +66,7 @@ spec = actual `shouldResolveTo` emptyObject it "should be able to @skip a fragment spread" $ do - let sourceQuery = [r| + let sourceQuery = [gql| { ...experimentalFragment @skip(if: true) } @@ -80,7 +80,7 @@ spec = actual `shouldResolveTo` emptyObject it "should be able to @skip an inline fragment" $ do - let sourceQuery = [r| + let sourceQuery = [gql| { ... on Query @skip(if: true) { experimentalField diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index f426e2c..5e0ae58 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -15,9 +15,9 @@ import Data.Text (Text) import Language.GraphQL import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.TH import Test.Hspec (Spec, describe, it) import Test.Hspec.GraphQL -import Text.RawString.QQ (r) size :: (Text, Value) size = ("size", String "L") @@ -34,16 +34,18 @@ garment typeName = ) inlineQuery :: Text -inlineQuery = [r|{ - garment { - ... on Hat { - circumference - } - ... on Shirt { - size +inlineQuery = [gql| + { + garment { + ... on Hat { + circumference + } + ... on Shirt { + size + } } } -}|] +|] shirtType :: Out.ObjectType IO shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList @@ -106,12 +108,14 @@ spec = do in actual `shouldResolveTo` expected it "embeds inline fragments without type" $ do - let sourceQuery = [r|{ - circumference - ... { - size + let sourceQuery = [gql| + { + circumference + ... { + size + } } - }|] + |] actual <- graphql (toSchema "circumference" circumference) sourceQuery let expected = HashMap.singleton "data" $ Aeson.object @@ -121,16 +125,18 @@ spec = do in actual `shouldResolveTo` expected it "evaluates fragments on Query" $ do - let sourceQuery = [r|{ - ... { - size + let sourceQuery = [gql| + { + ... { + size + } } - }|] + |] in graphql (toSchema "size" size) `shouldResolve` sourceQuery describe "Fragment spread executor" $ do it "evaluates fragment spreads" $ do - let sourceQuery = [r| + let sourceQuery = [gql| { ...circumferenceFragment } @@ -148,7 +154,7 @@ spec = do in actual `shouldResolveTo` expected it "evaluates nested fragments" $ do - let sourceQuery = [r| + let sourceQuery = [gql| { garment { ...circumferenceFragment @@ -174,7 +180,7 @@ spec = do in actual `shouldResolveTo` expected it "considers type condition" $ do - let sourceQuery = [r| + let sourceQuery = [gql| { garment { ...circumferenceFragment diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 1921ec9..9271c61 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -12,7 +12,7 @@ import Data.Aeson ((.=), object) import qualified Data.HashMap.Strict as HashMap import Language.GraphQL import Test.Hspec (Spec, describe, it) -import Text.RawString.QQ (r) +import Language.GraphQL.TH import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out import Test.Hspec.GraphQL @@ -42,7 +42,7 @@ spec :: Spec spec = describe "Root operation type" $ do it "returns objects from the root resolvers" $ do - let querySource = [r| + let querySource = [gql| { garment { circumference @@ -59,7 +59,7 @@ spec = actual `shouldResolveTo` expected it "chooses Mutation" $ do - let querySource = [r| + let querySource = [gql| mutation { incrementCircumference } |