diff options
28 files changed, 665 insertions, 282 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index ae76a2c..b9fc93f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,20 @@ The format is based on and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [Unreleased] +## [0.10.0.0] - 2020-08-29 +## Changed +- `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`. +- The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was + moved to `OperationDefinition` and `FragmentDefinition` since these are the + actual elements that have a location in the document. +- `Validate.Rules` get the whole validation context (AST and schema). + +## Added +- `Validate.Validation` contains data structures and functions used by the + validator and concretet rules. +- `Validate.Rules`: operation validation rules. + +## [0.9.0.0] - 2020-07-24 ## Fixed - Location of a parse error is returned in a singleton array with key `locations`. @@ -21,7 +34,7 @@ and this project adheres to - `Error.Error` is an error representation with a message and source location. - `Error.Response` represents a result of running a GraphQL query. - `Type.Schema` exports `Type` which lists all types possible in the schema. -- Parsing subscriptions (the execution always fails yet). +- Parsing subscriptions. - `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and `Type.Out.SourceEventStream` define subscription resolvers. - `Error.ResolverException` is an exception that can be thrown by (field value @@ -57,8 +70,6 @@ and this project adheres to ## Removed - `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver` represents possible resolver configurations. -- `Type.Out.Resolver`: It . Resolvers are a - part of the fields and are called `Trans.ResolverT`. - `Execute.executeWithName`. `Execute.execute` takes the operation name and completely replaces `executeWithName`. @@ -323,7 +334,8 @@ and this project adheres to ### Added - Data types for the GraphQL language. -[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...HEAD +[0.10.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.9.0.0...v0.10.0.0 +[0.9.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...v0.9.0.0 [0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0 [0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0 [0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0 @@ -1,10 +1,9 @@ -# Haskell GraphQL +# GraphQL implementation in Haskell [](https://hackage.haskell.org/package/graphql) [](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22) [](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE) - -GraphQL implementation in Haskell. +[](https://www.simplehaskell.org) This implementation is relatively low-level by design, it doesn't provide any mappings between the GraphQL types and Haskell's type system and avoids @@ -13,12 +12,19 @@ be built on top of it. ## State of the work -For now this only provides a parser and a printer for the GraphQL query language -and allows to execute queries and mutations using the given schema, but without -the validation step. But the idea is to be a Haskell port of +For now this library provides: + +- Parser for the query and schema languages, as well as a printer for the query + language (minimizer and pretty-printer). +- Data structures to define a type system. +- Executor (queries, mutations and subscriptions are supported). +- Validation is work in progress. +- Introspection isn't available yet. + +But the idea is to be a Haskell port of [`graphql-js`](https://github.com/graphql/graphql-js). -For the list of currently missing features see issues marked as +For a more precise list of currently missing features see issues marked as "[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)". ## Documentation @@ -29,6 +35,100 @@ API documentation is available through You'll also find a small tutorial with some examples under [docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial). +### Getting started + +We start with a simple GraphQL API that provides us with some famous and less +famous cites. + +```graphql +""" +Root Query type. +""" +type Query { + """ + Provides a cite. + """ + cite: String! +} +``` + +This is called a GraphQL schema, it defines all queries supported by the API. +`Query` is the root query type. Every GraphQL API should define a query type. + +`Query` has a single field `cite` that returns a `String`. The `!` after the +type denotes that the returned value cannot be `Null`. GraphQL fields are +nullable by default. + +To be able to work with this schema, we are going to implement it in Haskell. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Control.Exception (SomeException) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8 +import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.Out as Out + +-- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions. +-- Our first schema supports only queries. +schema :: Schema IO +schema = Schema + { query = queryType, mutation = Nothing, subscription = Nothing } + +-- GraphQL distinguishes between input and output types. Input types are field +-- argument types and they are defined in Language.GraphQL.Type.In. Output types +-- are result types, they are defined in Language.GraphQL.Type.Out. Root types +-- are always object types. +-- +-- Here we define a type "Query". The second argument is an optional +-- description, the third one is the list of interfaces implemented by the +-- object type. The last argument is a field map. Keys are field names, values +-- are field definitions and resolvers. Resolvers are the functions, where the +-- actual logic lives, they return values for the respective fields. +queryType :: Out.ObjectType IO +queryType = Out.ObjectType "Query" (Just "Root Query type.") [] + $ HashMap.singleton "cite" citeResolver + where + -- 'ValueResolver' is a 'Resolver' data constructor, it combines a field + -- definition with its resolver function. This function resolves a value for + -- a field (as opposed to the 'EventStreamResolver' used by subscriptions). + -- Our resolver just returns a constant value. + citeResolver = ValueResolver citeField + $ pure "Piscis primum a capite foetat" + -- The first argument is an optional field description. The second one is + -- the field type and the third one is for arguments (we have none in this + -- example). + -- + -- GraphQL has named and wrapping types. String is a scalar, named type. + -- Named types are nullable by default. To make our "cite" field + -- non-nullable, we wrap it in the wrapping type, Non-Null. + citeField = Out.Field + (Just "Provides a cite.") (Out.NonNullScalarType string) HashMap.empty + +-- Now we can execute a query. Since our schema defines only one field, +-- everything we can do is to ask to resolve it and give back the result. +-- Since subscriptions don't return plain values, the 'graphql' function returns +-- an 'Either'. 'Left' is for subscriptions, 'Right' is for queries and +-- mutations. +main :: IO () +main = do + Right result <- graphql schema "{ cite }" + ByteString.Lazy.Char8.putStrLn $ Aeson.encode result +``` + +Executing this query produces the following JSON: + +```json +{ + "data": { + "cite": "Piscis primum a capite foetat" + } +} +``` + ## Further information - [Contributing guidelines](CONTRIBUTING.md). diff --git a/graphql.cabal b/graphql.cabal index eb514e0..672f9b0 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -4,10 +4,10 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ba234bcfff46df053a3466359e32682c4592b88894911ecbe78bd00fa00929b5 +-- hash: 3ef060c57424074b84204bae61ee0a63e3470a7a060c45a977ff2bcbe4df8775 name: graphql -version: 0.8.0.0 +version: 0.10.0.0 synopsis: Haskell GraphQL implementation description: This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language. category: Language @@ -24,12 +24,10 @@ license-file: LICENSE build-type: Simple extra-source-files: CHANGELOG.md - README.md + CONTRIBUTING.md LICENSE + README.md docs/tutorial/tutorial.lhs -data-files: - tests/data/kitchen-sink.graphql - tests/data/kitchen-sink.min.graphql source-repository head type: git @@ -52,6 +50,7 @@ library Language.GraphQL.Type.Out Language.GraphQL.Type.Schema Language.GraphQL.Validate + Language.GraphQL.Validate.Validation Test.Hspec.GraphQL other-modules: Language.GraphQL.Execute.Execution @@ -91,7 +90,6 @@ test-suite tasty Language.GraphQL.ValidateSpec Test.DirectiveSpec Test.FragmentSpec - Test.KitchenSinkSpec Test.RootOperationSpec Test.StarWars.Data Test.StarWars.QuerySpec diff --git a/package.yaml b/package.yaml index dcdc6c8..a55c8a7 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: graphql -version: 0.9.0.0 +version: 0.10.0.0 synopsis: Haskell GraphQL implementation description: This package provides a rudimentary parser for the @@ -17,14 +17,11 @@ author: extra-source-files: - CHANGELOG.md -- README.md +- CONTRIBUTING.md - LICENSE +- README.md - docs/tutorial/tutorial.lhs -data-files: -- tests/data/*.graphql -- tests/data/*.min.graphql - dependencies: - aeson - base >= 4.7 && < 5 diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index 3d368d4..c7ceee8 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.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/. -} + -- | Target AST for parser. module Language.GraphQL.AST ( module Language.GraphQL.AST.Document diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs index 5b7a36f..c38c9ff 100644 --- a/src/Language/GraphQL/AST/DirectiveLocation.hs +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -1,5 +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/. -} + -- | Various parts of a GraphQL document can be annotated with directives. --- This module describes locations in a document where directives can appear. +-- This module describes locations in a document where directives can appear. module Language.GraphQL.AST.DirectiveLocation ( DirectiveLocation(..) , ExecutableDirectiveLocation(..) @@ -7,8 +11,8 @@ module Language.GraphQL.AST.DirectiveLocation ) where -- | All directives can be splitted in two groups: directives used to annotate --- various parts of executable definitions and the ones used in the schema --- definition. +-- various parts of executable definitions and the ones used in the schema +-- definition. data DirectiveLocation = ExecutableDirectiveLocation ExecutableDirectiveLocation | TypeSystemDirectiveLocation TypeSystemDirectiveLocation diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 3394bfa..72d39bb 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -62,6 +62,12 @@ data Location = Location , column :: Word } deriving (Eq, Show) +instance Ord Location where + compare (Location thisLine thisColumn) (Location thatLine thatColumn) + | thisLine < thatLine = LT + | thisLine > thatLine = GT + | otherwise = compare thisColumn thatColumn + -- ** Document -- | GraphQL document. @@ -69,7 +75,7 @@ type Document = NonEmpty Definition -- | All kinds of definitions that can occur in a GraphQL document. data Definition - = ExecutableDefinition ExecutableDefinition Location + = ExecutableDefinition ExecutableDefinition | TypeSystemDefinition TypeSystemDefinition Location | TypeSystemExtension TypeSystemExtension Location deriving (Eq, Show) @@ -84,13 +90,14 @@ data ExecutableDefinition -- | Operation definition. data OperationDefinition - = SelectionSet SelectionSet + = SelectionSet SelectionSet Location | OperationDefinition OperationType (Maybe Name) [VariableDefinition] [Directive] SelectionSet + Location deriving (Eq, Show) -- | GraphQL has 3 operation types: @@ -195,7 +202,7 @@ type Alias = Name -- | Fragment definition. data FragmentDefinition - = FragmentDefinition Name TypeCondition [Directive] SelectionSet + = FragmentDefinition Name TypeCondition [Directive] SelectionSet Location deriving (Eq, Show) -- | Type condition. diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index a0dac5b..ba89d36 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -50,8 +50,8 @@ document formatter defs | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' where encodeDocument = foldr executableDefinition [] defs - executableDefinition (ExecutableDefinition x _) acc = - definition formatter x : acc + executableDefinition (ExecutableDefinition executableDefinition') acc = + definition formatter executableDefinition' : acc executableDefinition _ acc = acc -- | Converts a t'ExecutableDefinition' into a string. @@ -68,12 +68,12 @@ definition formatter x -- | Converts a 'OperationDefinition into a string. operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text operationDefinition formatter = \case - SelectionSet sels -> selectionSet formatter sels - OperationDefinition Query name vars dirs sels -> + SelectionSet sels _ -> selectionSet formatter sels + OperationDefinition Query name vars dirs sels _ -> "query " <> node formatter name vars dirs sels - OperationDefinition Mutation name vars dirs sels -> + OperationDefinition Mutation name vars dirs sels _ -> "mutation " <> node formatter name vars dirs sels - OperationDefinition Subscription name vars dirs sels -> + OperationDefinition Subscription name vars dirs sels _ -> "subscription " <> node formatter name vars dirs sels -- | Converts a Query or Mutation into a string. @@ -190,7 +190,7 @@ inlineFragment formatter tc dirs sels = "... on " <> selectionSet formatter sels fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text -fragmentDefinition formatter (FragmentDefinition name tc dirs sels) +fragmentDefinition formatter (FragmentDefinition name tc dirs sels _) = "fragment " <> Lazy.Text.fromStrict name <> " on " <> Lazy.Text.fromStrict tc <> optempty (directives formatter) dirs diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 687d8f5..7bc51cb 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -21,7 +21,8 @@ import Language.GraphQL.AST.DirectiveLocation import Language.GraphQL.AST.Document import Language.GraphQL.AST.Lexer import Text.Megaparsec - ( SourcePos(..) + ( MonadParsec(..) + , SourcePos(..) , getSourcePos , lookAhead , option @@ -37,15 +38,11 @@ document = unicodeBOM *> lexeme (NonEmpty.some definition) definition :: Parser Definition -definition = executableDefinition' +definition = ExecutableDefinition <$> executableDefinition <|> typeSystemDefinition' <|> typeSystemExtension' <?> "Definition" where - executableDefinition' = do - location <- getLocation - definition' <- executableDefinition - pure $ ExecutableDefinition definition' location typeSystemDefinition' = do location <- getLocation definition' <- typeSystemDefinition @@ -349,16 +346,22 @@ operationTypeDefinition = OperationTypeDefinition <?> "OperationTypeDefinition" operationDefinition :: Parser OperationDefinition -operationDefinition = SelectionSet <$> selectionSet +operationDefinition = shorthand <|> operationDefinition' <?> "OperationDefinition" where - operationDefinition' - = OperationDefinition <$> operationType - <*> optional name - <*> variableDefinitions - <*> directives - <*> selectionSet + shorthand = do + location <- getLocation + selectionSet' <- selectionSet + pure $ SelectionSet selectionSet' location + operationDefinition' = do + location <- getLocation + operationType' <- operationType + operationName <- optional name + variableDefinitions' <- variableDefinitions + directives' <- directives + selectionSet' <- selectionSet + pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location operationType :: Parser OperationType operationType = Query <$ symbol "query" @@ -412,13 +415,15 @@ inlineFragment = InlineFragment <?> "InlineFragment" fragmentDefinition :: Parser FragmentDefinition -fragmentDefinition = FragmentDefinition - <$ symbol "fragment" - <*> name - <*> typeCondition - <*> directives - <*> selectionSet - <?> "FragmentDefinition" +fragmentDefinition = label "FragmentDefinition" $ do + location <- getLocation + _ <- symbol "fragment" + fragmentName' <- name + typeCondition' <- typeCondition + directives' <- directives + selectionSet' <- selectionSet + pure $ FragmentDefinition + fragmentName' typeCondition' directives' selectionSet' location fragmentName :: Parser Name fragmentName = but (symbol "on") *> name <?> "FragmentName" diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 60fb71d..08a2fc0 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.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 ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index d8d5b13..71a2baa 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -83,30 +83,6 @@ resolveAbstractType abstractType values' _ -> pure Nothing | otherwise = pure Nothing -doesFragmentTypeApply :: forall m - . CompositeType m - -> Out.ObjectType m - -> Bool -doesFragmentTypeApply (CompositeObjectType fragmentType) objectType = - fragmentType == objectType -doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType = - instanceOf objectType $ AbstractInterfaceType fragmentType -doesFragmentTypeApply (CompositeUnionType fragmentType) objectType = - instanceOf objectType $ AbstractUnionType fragmentType - -instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool -instanceOf objectType (AbstractInterfaceType interfaceType) = - let Out.ObjectType _ _ interfaces _ = objectType - in foldr go False interfaces - where - go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc = - acc || foldr go (interfaceType == objectInterfaceType) interfaces -instanceOf objectType (AbstractUnionType unionType) = - let Out.UnionType _ _ members = unionType - in foldr go False members - where - go unionMemberType acc = acc || objectType == unionMemberType - executeField :: (MonadCatch m, Serialize a) => Out.Resolver m -> Type.Value diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 76d1fe7..9c7ad0a 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -255,18 +255,18 @@ defragment ast = in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations where defragment' definition (operations, fragments') - | (Full.ExecutableDefinition executable _) <- definition + | (Full.ExecutableDefinition executable) <- definition , (Full.DefinitionOperation operation') <- executable = (transform operation' : operations, fragments') - | (Full.ExecutableDefinition executable _) <- definition + | (Full.ExecutableDefinition executable) <- definition , (Full.DefinitionFragment fragment) <- executable - , (Full.FragmentDefinition name _ _ _) <- fragment = + , (Full.FragmentDefinition name _ _ _ _) <- fragment = (operations, HashMap.insert name fragment fragments') defragment' _ acc = acc transform = \case - Full.OperationDefinition type' name variables directives' selections -> + Full.OperationDefinition type' name variables directives' selections _ -> OperationDefinition type' name variables directives' selections - Full.SelectionSet selectionSet -> + Full.SelectionSet selectionSet _ -> OperationDefinition Full.Query Nothing mempty mempty selectionSet -- * Operation @@ -324,8 +324,8 @@ selection (Full.InlineFragment type' directives' selections) = do case type' of Nothing -> pure $ Left fragmentSelectionSet Just typeName -> do - typeCondition' <- lookupTypeCondition typeName - case typeCondition' of + types' <- gets types + case lookupTypeCondition typeName types' of Just typeCondition -> pure $ selectionFragment typeCondition fragmentSelectionSet Nothing -> pure $ Left mempty @@ -364,29 +364,17 @@ collectFragments = do _ <- fragmentDefinition nextValue collectFragments -lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m)) -lookupTypeCondition type' = do - types' <- gets types - case HashMap.lookup type' types' of - Just (ObjectType objectType) -> - lift $ pure $ Just $ CompositeObjectType objectType - Just (UnionType unionType) -> - lift $ pure $ Just $ CompositeUnionType unionType - Just (InterfaceType interfaceType) -> - lift $ pure $ Just $ CompositeInterfaceType interfaceType - _ -> lift $ pure Nothing - fragmentDefinition :: Full.FragmentDefinition -> State (Replacement m) (Maybe (Fragment m)) -fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do +fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do modify deleteFragmentDefinition fragmentSelection <- appendSelection selections - compositeType <- lookupTypeCondition type' + types' <- gets types - case compositeType of - Just compositeType' -> do - let newValue = Fragment compositeType' fragmentSelection + case lookupTypeCondition type' types' of + Just compositeType -> do + let newValue = Fragment compositeType fragmentSelection modify $ insertFragment newValue lift $ pure $ Just newValue _ -> lift $ pure Nothing diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index 36e0e2c..8b08041 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.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 PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 9121d13..6f25777 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -8,6 +8,9 @@ module Language.GraphQL.Type.Internal ( AbstractType(..) , CompositeType(..) , collectReferencedTypes + , doesFragmentTypeApply + , instanceOf + , lookupTypeCondition ) where import Data.HashMap.Strict (HashMap) @@ -89,3 +92,39 @@ collectReferencedTypes schema = polymorphicTraverser interfaces fields = flip (foldr visitFields) fields . flip (foldr traverseInterfaceType) interfaces + +doesFragmentTypeApply :: forall m + . CompositeType m + -> Out.ObjectType m + -> Bool +doesFragmentTypeApply (CompositeObjectType fragmentType) objectType = + fragmentType == objectType +doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType = + instanceOf objectType $ AbstractInterfaceType fragmentType +doesFragmentTypeApply (CompositeUnionType fragmentType) objectType = + instanceOf objectType $ AbstractUnionType fragmentType + +instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool +instanceOf objectType (AbstractInterfaceType interfaceType) = + let Out.ObjectType _ _ interfaces _ = objectType + in foldr go False interfaces + where + go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc = + acc || foldr go (interfaceType == objectInterfaceType) interfaces +instanceOf objectType (AbstractUnionType unionType) = + let Out.UnionType _ _ members = unionType + in foldr go False members + where + go unionMemberType acc = acc || objectType == unionMemberType + +lookupTypeCondition :: forall m + . Name + -> HashMap Name (Type m) + -> Maybe (CompositeType m) +lookupTypeCondition type' types' = + case HashMap.lookup type' types' of + Just (ObjectType objectType) -> Just $ CompositeObjectType objectType + Just (UnionType unionType) -> Just $ CompositeUnionType unionType + Just (InterfaceType interfaceType) -> + Just $ CompositeInterfaceType interfaceType + _ -> Nothing diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index c5cc6fd..581d9b2 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.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/. -} + -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 5768615..53dc6f9 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -13,73 +13,50 @@ module Language.GraphQL.Validate , module Language.GraphQL.Validate.Rules ) where -import Control.Monad.Trans.Reader (Reader, asks, runReader) +import Control.Monad (foldM) +import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader) import Data.Foldable (foldrM) import Data.Sequence (Seq(..), (><), (|>)) import qualified Data.Sequence as Seq -import Data.Text (Text) import Language.GraphQL.AST.Document -import Language.GraphQL.Type.Schema +import Language.GraphQL.Type.Internal +import Language.GraphQL.Type.Schema (Schema(..)) import Language.GraphQL.Validate.Rules +import Language.GraphQL.Validate.Validation -data Context m = Context - { ast :: Document - , schema :: Schema m - , rules :: [Rule] - } - -type ValidateT m = Reader (Context m) (Seq Error) - --- | 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 --- whether a null result is intentional or caused by a runtime error. -data Path - = Segment Text -- ^ Field name. - | Index Int -- ^ List index if a field returned a list. - deriving (Eq, Show) - --- | Validation error. -data Error = Error - { message :: String - , locations :: [Location] - , path :: [Path] - } deriving (Eq, Show) +type ValidateT m = Reader (Validation m) (Seq Error) -- | Validates a document and returns a list of found errors. If the returned -- list is empty, the document is valid. -document :: forall m. Schema m -> [Rule] -> Document -> Seq Error +document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error document schema' rules' document' = runReader (foldrM go Seq.empty document') context where - context = Context + context = Validation { ast = document' , schema = schema' + , types = collectReferencedTypes schema' , rules = rules' } go definition' accumulator = (accumulator ><) <$> definition definition' definition :: forall m. Definition -> ValidateT m definition = \case - definition'@(ExecutableDefinition executableDefinition' _) -> do + definition'@(ExecutableDefinition executableDefinition') -> do applied <- applyRules definition' children <- executableDefinition executableDefinition' pure $ children >< applied definition' -> applyRules definition' where - applyRules definition' = foldr (ruleFilter definition') Seq.empty - <$> asks rules - ruleFilter definition' (DefinitionRule rule) accumulator - | Just message' <- rule definition' = - accumulator |> Error - { message = message' - , locations = [definitionLocation definition'] - , path = [] - } - | otherwise = accumulator - definitionLocation (ExecutableDefinition _ location) = location - definitionLocation (TypeSystemDefinition _ location) = location - definitionLocation (TypeSystemExtension _ location) = location + applyRules definition' = + asks rules >>= foldM (ruleFilter definition') Seq.empty + ruleFilter definition' accumulator (DefinitionRule rule) = + mapReaderT (runRule accumulator) $ rule definition' + ruleFilter _ accumulator _ = pure accumulator + +runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error) +runRule accumulator (Just error') = pure $ accumulator |> error' +runRule accumulator Nothing = pure accumulator executableDefinition :: forall m. ExecutableDefinition -> ValidateT m executableDefinition (DefinitionOperation definition') = @@ -88,10 +65,17 @@ executableDefinition (DefinitionFragment definition') = fragmentDefinition definition' operationDefinition :: forall m. OperationDefinition -> ValidateT m -operationDefinition (SelectionSet _operation) = - pure Seq.empty -operationDefinition (OperationDefinition _type _name _variables _directives _selection) = - pure Seq.empty +operationDefinition operation = + asks rules >>= foldM ruleFilter Seq.empty + where + ruleFilter accumulator (OperationDefinitionRule rule) = + mapReaderT (runRule accumulator) $ rule operation + ruleFilter accumulator _ = pure accumulator fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m -fragmentDefinition _fragment = pure Seq.empty +fragmentDefinition fragment = + asks rules >>= foldM ruleFilter Seq.empty + where + ruleFilter accumulator (FragmentDefinitionRule rule) = + mapReaderT (runRule accumulator) $ rule fragment + ruleFilter accumulator _ = pure accumulator diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index a3314e7..690631e 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -2,30 +2,214 @@ 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 LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + -- | This module contains default rules defined in the GraphQL specification. module Language.GraphQL.Validate.Rules - ( Rule(..) - , executableDefinitionsRule + ( executableDefinitionsRule + , loneAnonymousOperationRule + , singleFieldSubscriptionsRule , specifiedRules + , uniqueFragmentNamesRule + , uniqueOperationNamesRule ) where +import Control.Monad (foldM) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Reader (asks) +import Control.Monad.Trans.State (evalStateT, gets, modify) +import qualified Data.HashSet as HashSet +import qualified Data.Text as Text import Language.GraphQL.AST.Document +import Language.GraphQL.Type.Internal +import qualified Language.GraphQL.Type.Schema as Schema +import Language.GraphQL.Validate.Validation --- | 'Rule' assigns a function to each AST node that can be validated. If the --- validation fails, the function should return an error message, or 'Nothing' --- otherwise. -newtype Rule - = DefinitionRule (Definition -> Maybe String) - --- | Default reules given in the specification. -specifiedRules :: [Rule] +-- | Default rules given in the specification. +specifiedRules :: forall m. [Rule m] specifiedRules = [ executableDefinitionsRule + , singleFieldSubscriptionsRule + , loneAnonymousOperationRule + , uniqueOperationNamesRule + , uniqueFragmentNamesRule ] -- | Definition must be OperationDefinition or FragmentDefinition. -executableDefinitionsRule :: Rule -executableDefinitionsRule = DefinitionRule go +executableDefinitionsRule :: forall m. Rule m +executableDefinitionsRule = DefinitionRule $ \case + ExecutableDefinition _ -> lift Nothing + TypeSystemDefinition _ location -> pure $ error' location + TypeSystemExtension _ location -> pure $ error' location + where + error' location = Error + { message = + "Definition must be OperationDefinition or FragmentDefinition." + , locations = [location] + , path = [] + } + +-- | Subscription operations must have exactly one root field. +singleFieldSubscriptionsRule :: forall m. Rule m +singleFieldSubscriptionsRule = OperationDefinitionRule $ \case + OperationDefinition Subscription name' _ _ rootFields location -> do + groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty + case HashSet.size groupedFieldSet of + 1 -> lift Nothing + _ + | Just name <- name' -> pure $ Error + { message = unwords + [ "Subscription" + , Text.unpack name + , "must select only one top level field." + ] + , locations = [location] + , path = [] + } + | otherwise -> pure $ Error + { message = errorMessage + , locations = [location] + , path = [] + } + _ -> lift Nothing + where + errorMessage = + "Anonymous Subscription must select only one top level field." + collectFields selectionSet = foldM forEach HashSet.empty selectionSet + forEach accumulator (Field alias name _ directives _) + | any skip directives = pure accumulator + | Just aliasedName <- alias = pure + $ HashSet.insert aliasedName accumulator + | otherwise = pure $ HashSet.insert name accumulator + forEach accumulator (FragmentSpread fragmentName directives) + | any skip directives = pure accumulator + | otherwise = do + inVisitetFragments <- gets $ HashSet.member fragmentName + if inVisitetFragments + then pure accumulator + else collectFromSpread fragmentName accumulator + forEach accumulator (InlineFragment typeCondition' directives selectionSet) + | any skip directives = pure accumulator + | Just typeCondition <- typeCondition' = + collectFromFragment typeCondition selectionSet accumulator + | otherwise = HashSet.union accumulator + <$> collectFields selectionSet + skip (Directive "skip" [Argument "if" (Boolean True)]) = True + skip (Directive "include" [Argument "if" (Boolean False)]) = True + skip _ = False + findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing + | DefinitionFragment fragmentDefinition <- executableDefinition = + Just fragmentDefinition + findFragmentDefinition _ accumulator = accumulator + collectFromFragment typeCondition selectionSet accumulator = do + types' <- lift $ asks types + schema' <- lift $ asks schema + case lookupTypeCondition typeCondition types' of + Nothing -> pure accumulator + Just compositeType + | Just objectType <- Schema.subscription schema' + , True <- doesFragmentTypeApply compositeType objectType -> + HashSet.union accumulator<$> collectFields selectionSet + | otherwise -> pure accumulator + collectFromSpread fragmentName accumulator = do + modify $ HashSet.insert fragmentName + ast' <- lift $ asks ast + case foldr findFragmentDefinition Nothing ast' of + Nothing -> pure accumulator + Just (FragmentDefinition _ typeCondition _ selectionSet _) -> + collectFromFragment typeCondition selectionSet accumulator + +-- | GraphQL allows a short‐hand form for defining query operations when only +-- that one operation exists in the document. +loneAnonymousOperationRule :: forall m. Rule m +loneAnonymousOperationRule = OperationDefinitionRule $ \case + SelectionSet _ thisLocation -> check thisLocation + OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation + _ -> lift Nothing + where + check thisLocation = asks ast + >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing + filterAnonymousOperations thisLocation definition Nothing + | (viewOperation -> Just operationDefinition) <- definition = + compareAnonymousOperations thisLocation operationDefinition + filterAnonymousOperations _ _ accumulator = accumulator + compareAnonymousOperations thisLocation = \case + OperationDefinition _ _ _ _ _ thatLocation + | thisLocation /= thatLocation -> pure $ error' thisLocation + SelectionSet _ thatLocation + | thisLocation /= thatLocation -> pure $ error' thisLocation + _ -> Nothing + error' location = Error + { message = + "This anonymous operation must be the only defined operation." + , locations = [location] + , path = [] + } + +-- | Each named operation definition must be unique within a document when +-- referred to by its name. +uniqueOperationNamesRule :: forall m. Rule m +uniqueOperationNamesRule = OperationDefinitionRule $ \case + OperationDefinition _ (Just thisName) _ _ _ thisLocation -> + findDuplicates (filterByName thisName) thisLocation (error' thisName) + _ -> lift Nothing + where + error' operationName = concat + [ "There can be only one operation named \"" + , Text.unpack operationName + , "\"." + ] + filterByName thisName definition' accumulator + | (viewOperation -> Just operationDefinition) <- definition' + , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition + , thisName == thatName = thatLocation : accumulator + | otherwise = accumulator + +findDuplicates :: (Definition -> [Location] -> [Location]) + -> Location + -> String + -> RuleT m +findDuplicates filterByName thisLocation errorMessage = do + ast' <- asks ast + let locations' = foldr filterByName [] ast' + if length locations' > 1 && head locations' == thisLocation + then pure $ error' locations' + else lift Nothing + where + error' locations' = Error + { message = errorMessage + , locations = locations' + , path = [] + } + +viewOperation :: Definition -> Maybe OperationDefinition +viewOperation definition + | ExecutableDefinition executableDefinition <- definition + , DefinitionOperation operationDefinition <- executableDefinition = + Just operationDefinition +viewOperation _ = Nothing + +-- | Fragment definitions are referenced in fragment spreads by name. To avoid +-- ambiguity, each fragment’s name must be unique within a document. +-- +-- Inline fragments are not considered fragment definitions, and are unaffected +-- by this validation rule. +uniqueFragmentNamesRule :: forall m. Rule m +uniqueFragmentNamesRule = FragmentDefinitionRule $ \case + FragmentDefinition thisName _ _ _ thisLocation -> + findDuplicates (filterByName thisName) thisLocation (error' thisName) where - go (ExecutableDefinition _definition _) = Nothing - go _ = Just "Definition must be OperationDefinition or FragmentDefinition." + error' fragmentName = concat + [ "There can be only one fragment named \"" + , Text.unpack fragmentName + , "\"." + ] + filterByName thisName definition accumulator + | ExecutableDefinition executableDefinition <- definition + , DefinitionFragment fragmentDefinition <- executableDefinition + , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition + , thisName == thatName = thatLocation : accumulator + | otherwise = accumulator diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs new file mode 100644 index 0000000..03bbf33 --- /dev/null +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -0,0 +1,54 @@ +{- 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/. -} + +-- | Definitions used by the validation rules and the validator itself. +module Language.GraphQL.Validate.Validation + ( Error(..) + , Path(..) + , Rule(..) + , RuleT + , Validation(..) + ) where + +import Control.Monad.Trans.Reader (ReaderT(..)) +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Language.GraphQL.AST.Document +import Language.GraphQL.Type.Schema (Schema) +import qualified Language.GraphQL.Type.Schema as Schema + +-- | 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 +-- whether a null result is intentional or caused by a runtime error. +data Path + = Segment Text -- ^ Field name. + | Index Int -- ^ List index if a field returned a list. + deriving (Eq, Show) + +-- | Validation error. +data Error = Error + { message :: String + , locations :: [Location] + , path :: [Path] + } deriving (Eq, Show) + +-- | Validation rule context. +data Validation m = Validation + { ast :: Document + , schema :: Schema m + , types :: HashMap Name (Schema.Type m) + , rules :: [Rule m] + } + +-- | 'Rule' assigns a function to each AST node that can be validated. If the +-- validation fails, the function should return an error message, or 'Nothing' +-- otherwise. +data Rule m + = DefinitionRule (Definition -> RuleT m) + | OperationDefinitionRule (OperationDefinition -> RuleT m) + | FragmentDefinitionRule (FragmentDefinition -> RuleT m) + +-- | Monad transformer used by the rules. +type RuleT m = ReaderT (Validation m) Maybe Error diff --git a/src/Test/Hspec/GraphQL.hs b/src/Test/Hspec/GraphQL.hs index 093685b..253b366 100644 --- a/src/Test/Hspec/GraphQL.hs +++ b/src/Test/Hspec/GraphQL.hs @@ -11,6 +11,7 @@ module Test.Hspec.GraphQL , shouldResolveTo ) where +import Control.Monad.Catch (MonadCatch) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) @@ -18,8 +19,8 @@ import Language.GraphQL.Error import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy) -- | Asserts that a query resolves to some value. -shouldResolveTo - :: Either (ResponseEventStream IO Aeson.Value) Aeson.Object +shouldResolveTo :: MonadCatch m + => Either (ResponseEventStream m Aeson.Value) Aeson.Object -> Aeson.Object -> Expectation shouldResolveTo (Right actual) expected = actual `shouldBe` expected @@ -27,8 +28,8 @@ shouldResolveTo _ _ = expectationFailure "the query is expected to resolve to a value, but it resolved to an event stream" -- | Asserts that the response doesn't contain any errors. -shouldResolve - :: (Text -> IO (Either (ResponseEventStream IO Aeson.Value) Aeson.Object)) +shouldResolve :: MonadCatch m + => (Text -> IO (Either (ResponseEventStream m Aeson.Value) Aeson.Object)) -> Text -> Expectation shouldResolve executor query = do @@ -1,4 +1,4 @@ -resolver: lts-16.6 +resolver: lts-16.11 packages: - . diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index 71ee948..5fa3706 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -123,7 +123,9 @@ spec = do it "indents block strings in arguments" $ let arguments = [Argument "message" (String "line1\nline2")] field = Field Nothing "field" arguments [] [] - operation = DefinitionOperation $ SelectionSet $ pure field + operation = DefinitionOperation + $ SelectionSet (pure field) + $ Location 0 0 in definition pretty operation `shouldBe` [r|{ field(message: """ line1 diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs index 482dc3a..1497c48 100644 --- a/tests/Language/GraphQL/ErrorSpec.hs +++ b/tests/Language/GraphQL/ErrorSpec.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 OverloadedStrings #-} module Language.GraphQL.ErrorSpec ( spec diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs index 339c2e3..2b00895 100644 --- a/tests/Language/GraphQL/Execute/CoerceSpec.hs +++ b/tests/Language/GraphQL/Execute/CoerceSpec.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 OverloadedStrings #-} module Language.GraphQL.Execute.CoerceSpec ( spec diff --git a/tests/Language/GraphQL/Type/OutSpec.hs b/tests/Language/GraphQL/Type/OutSpec.hs index eecc374..733763d 100644 --- a/tests/Language/GraphQL/Type/OutSpec.hs +++ b/tests/Language/GraphQL/Type/OutSpec.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 OverloadedStrings #-} module Language.GraphQL.Type.OutSpec ( spec diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index f84322d..8f6626b 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -148,7 +148,7 @@ validate queryString = spec :: Spec spec = - describe "document" $ + describe "document" $ do it "rejects type definitions" $ let queryString = [r| query getDogName { @@ -169,3 +169,115 @@ spec = , path = [] } in validate queryString `shouldBe` Seq.singleton expected + + it "rejects multiple subscription root fields" $ + let queryString = [r| + subscription sub { + newMessage { + body + sender + } + disallowedSecondRootField + } + |] + expected = Error + { message = + "Subscription sub must select only one top level field." + , locations = [AST.Location 2 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected + + it "rejects multiple subscription root fields coming from a fragment" $ + let queryString = [r| + subscription sub { + ...multipleSubscriptions + } + + fragment multipleSubscriptions on Subscription { + newMessage { + body + sender + } + disallowedSecondRootField + } + |] + expected = Error + { message = + "Subscription sub must select only one top level field." + , locations = [AST.Location 2 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected + + it "rejects multiple anonymous operations" $ + let queryString = [r| + { + dog { + name + } + } + + query getName { + dog { + owner { + name + } + } + } + |] + expected = Error + { message = + "This anonymous operation must be the only defined operation." + , locations = [AST.Location 2 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected + + it "rejects operations with the same name" $ + let queryString = [r| + query dogOperation { + dog { + name + } + } + + mutation dogOperation { + mutateDog { + id + } + } + |] + expected = Error + { message = + "There can be only one operation named \"dogOperation\"." + , locations = [AST.Location 2 15, AST.Location 8 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected + + it "rejects fragments with the same name" $ + let queryString = [r| + { + dog { + ...fragmentOne + } + } + + fragment fragmentOne on Dog { + name + } + + fragment fragmentOne on Dog { + owner { + name + } + } + |] + expected = Error + { message = + "There can be only one fragment named \"fragmentOne\"." + , locations = [AST.Location 8 15, AST.Location 12 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected diff --git a/tests/Test/KitchenSinkSpec.hs b/tests/Test/KitchenSinkSpec.hs deleted file mode 100644 index 9f5a947..0000000 --- a/tests/Test/KitchenSinkSpec.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module Test.KitchenSinkSpec - ( spec - ) where - -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy.IO as Text.Lazy.IO -import qualified Data.Text.Lazy as Lazy (Text) -import qualified Language.GraphQL.AST.Encoder as Encoder -import qualified Language.GraphQL.AST.Parser as Parser -import Paths_graphql (getDataFileName) -import Test.Hspec (Spec, describe, it) -import Test.Hspec.Megaparsec (parseSatisfies) -import Text.Megaparsec (parse) -import Text.RawString.QQ (r) - -spec :: Spec -spec = describe "Kitchen Sink" $ do - it "minifies the query" $ do - dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql" - minFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql" - expected <- Text.Lazy.IO.readFile minFileName - - shouldNormalize Encoder.minified dataFileName expected - - it "pretty prints the query" $ do - dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql" - let expected = [r|query queryName($foo: ComplexType, $site: Site = MOBILE) { - whoever123is: node(id: [123, 456]) { - id - ... on User @defer { - field2 { - id - alias: field1(first: 10, after: $foo) @include(if: $foo) { - id - ...frag - } - } - } - } -} - -mutation likeStory { - like(story: 123) @defer { - story { - id - } - } -} - -fragment frag on Friend { - foo(size: $size, bar: $b, obj: {key: "value"}) -} - -{ - unnamed(truthy: true, falsey: false) - query -} -|] - - shouldNormalize Encoder.pretty dataFileName expected - -shouldNormalize :: Encoder.Formatter -> FilePath -> Lazy.Text -> IO () -shouldNormalize formatter dataFileName expected = do - actual <- Text.IO.readFile dataFileName - parse Parser.document dataFileName actual `parseSatisfies` condition - where - condition = (expected ==) . Encoder.document formatter diff --git a/tests/data/kitchen-sink.graphql b/tests/data/kitchen-sink.graphql deleted file mode 100644 index 89903b7..0000000 --- a/tests/data/kitchen-sink.graphql +++ /dev/null @@ -1,38 +0,0 @@ -# Copyright (c) 2015, Facebook, Inc. -# All rights reserved. -# -# This source code is licensed under the BSD-style license found in the -# LICENSE file in the root directory of this source tree. An additional grant -# of patent rights can be found in the PATENTS file in the same directory. - -query queryName($foo: ComplexType, $site: Site = MOBILE) { - whoever123is: node(id: [123, 456]) { - id, # Inline test comment - ... on User @defer { - field2 { - id, - alias: field1(first: 10, after: $foo) @include(if: $foo) { - id, - ...frag - } - } - } - } -} - -mutation likeStory { - like(story: 123) @defer { - story { - id - } - } -} - -fragment frag on Friend { - foo(size: $size, bar: $b, obj: {key: "value"}) -} - -{ - unnamed(truthy: true, falsey: false), - query -} diff --git a/tests/data/kitchen-sink.min.graphql b/tests/data/kitchen-sink.min.graphql deleted file mode 100644 index 24f5c26..0000000 --- a/tests/data/kitchen-sink.min.graphql +++ /dev/null @@ -1 +0,0 @@ -query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:"value"})}{unnamed(truthy:true,falsey:false),query} |