From 44d506d4b57e450480cf9c476bd927a43ad9c25d Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Mon, 20 Jul 2020 21:29:12 +0200 Subject: [PATCH] Draft the Validation API --- graphql.cabal | 5 +- package.yaml | 1 + src/Language/GraphQL.hs | 24 ++- src/Language/GraphQL/AST/Document.hs | 6 +- src/Language/GraphQL/AST/Encoder.hs | 3 +- src/Language/GraphQL/AST/Parser.hs | 37 ++++- src/Language/GraphQL/Execute/Transform.hs | 4 +- src/Language/GraphQL/Validate.hs | 89 +++++++++++ src/Language/GraphQL/Validate/Rules.hs | 25 ++++ tests/Language/GraphQL/AST/ParserSpec.hs | 5 +- tests/Language/GraphQL/ValidateSpec.hs | 171 ++++++++++++++++++++++ 11 files changed, 355 insertions(+), 15 deletions(-) create mode 100644 src/Language/GraphQL/Validate.hs create mode 100644 src/Language/GraphQL/Validate/Rules.hs create mode 100644 tests/Language/GraphQL/ValidateSpec.hs diff --git a/graphql.cabal b/graphql.cabal index bb78d22..eb514e0 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ca820b1bb2b81ffca4a3e2563bfa2be5381d80eaf4085595e07cf7db2aa3c6a9 +-- hash: ba234bcfff46df053a3466359e32682c4592b88894911ecbe78bd00fa00929b5 name: graphql version: 0.8.0.0 @@ -51,6 +51,7 @@ library Language.GraphQL.Type.In Language.GraphQL.Type.Out Language.GraphQL.Type.Schema + Language.GraphQL.Validate Test.Hspec.GraphQL other-modules: Language.GraphQL.Execute.Execution @@ -58,6 +59,7 @@ library Language.GraphQL.Execute.Transform Language.GraphQL.Type.Definition Language.GraphQL.Type.Internal + Language.GraphQL.Validate.Rules hs-source-dirs: src build-depends: @@ -86,6 +88,7 @@ test-suite tasty Language.GraphQL.Execute.CoerceSpec Language.GraphQL.ExecuteSpec Language.GraphQL.Type.OutSpec + Language.GraphQL.ValidateSpec Test.DirectiveSpec Test.FragmentSpec Test.KitchenSinkSpec diff --git a/package.yaml b/package.yaml index ac3b114..d24e4ba 100644 --- a/package.yaml +++ b/package.yaml @@ -47,6 +47,7 @@ library: - Language.GraphQL.Execute.Transform - Language.GraphQL.Type.Definition - Language.GraphQL.Type.Internal + - Language.GraphQL.Validate.Rules tests: tasty: diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index be375ed..9fce1d3 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -16,6 +16,7 @@ import Data.Text (Text) import Language.GraphQL.AST import Language.GraphQL.Error import Language.GraphQL.Execute +import qualified Language.GraphQL.Validate as Validate import Language.GraphQL.Type.Schema import Text.Megaparsec (parse) @@ -39,9 +40,16 @@ graphqlSubs :: MonadCatch m graphqlSubs schema operationName variableValues document' = case parse document "" document' of Left errorBundle -> pure . formatResponse <$> parseError errorBundle - Right parsed -> fmap formatResponse - <$> execute schema operationName variableValues parsed + Right parsed -> + case validate parsed of + Seq.Empty -> fmap formatResponse + <$> execute schema operationName variableValues parsed + errors -> pure $ pure + $ HashMap.singleton "errors" + $ Aeson.toJSON + $ fromValidationError <$> errors where + validate = Validate.document schema Validate.specifiedRules formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data'' formatResponse (Response data'' errors') = HashMap.fromList [ ("data", data'') @@ -53,6 +61,18 @@ graphqlSubs schema operationName variableValues document' = [ ("message", Aeson.toJSON message) , ("locations", Aeson.listValue fromLocation locations) ] + fromValidationError Validate.Error{..} + | [] <- path = Aeson.object + [ ("message", Aeson.toJSON message) + , ("locations", Aeson.listValue fromLocation locations) + ] + | otherwise = Aeson.object + [ ("message", Aeson.toJSON message) + , ("locations", Aeson.listValue fromLocation locations) + , ("path", Aeson.listValue fromPath path) + ] + fromPath (Validate.Segment segment) = Aeson.String segment + fromPath (Validate.Index index) = Aeson.toJSON index fromLocation Location{..} = Aeson.object [ ("line", Aeson.toJSON line) , ("column", Aeson.toJSON column) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index cd1dbc6..3394bfa 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -69,9 +69,9 @@ type Document = NonEmpty Definition -- | All kinds of definitions that can occur in a GraphQL document. data Definition - = ExecutableDefinition ExecutableDefinition - | TypeSystemDefinition TypeSystemDefinition - | TypeSystemExtension TypeSystemExtension + = ExecutableDefinition ExecutableDefinition Location + | TypeSystemDefinition TypeSystemDefinition Location + | TypeSystemExtension TypeSystemExtension Location deriving (Eq, Show) -- | Top-level definition of a document, either an operation or a fragment. diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index b55566d..a0dac5b 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -50,7 +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 x _) acc = + definition formatter x : acc executableDefinition _ acc = acc -- | Converts a t'ExecutableDefinition' into a string. diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index ea517da..687d8f5 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | @GraphQL@ document parser. module Language.GraphQL.AST.Parser @@ -19,7 +20,15 @@ import Language.GraphQL.AST.DirectiveLocation ) import Language.GraphQL.AST.Document import Language.GraphQL.AST.Lexer -import Text.Megaparsec (lookAhead, option, try, ()) +import Text.Megaparsec + ( SourcePos(..) + , getSourcePos + , lookAhead + , option + , try + , unPos + , () + ) -- | Parser for the GraphQL documents. document :: Parser Document @@ -28,10 +37,30 @@ document = unicodeBOM *> lexeme (NonEmpty.some definition) definition :: Parser Definition -definition = ExecutableDefinition <$> executableDefinition - <|> TypeSystemDefinition <$> typeSystemDefinition - <|> TypeSystemExtension <$> typeSystemExtension +definition = executableDefinition' + <|> typeSystemDefinition' + <|> typeSystemExtension' "Definition" + where + executableDefinition' = do + location <- getLocation + definition' <- executableDefinition + pure $ ExecutableDefinition definition' location + typeSystemDefinition' = do + location <- getLocation + definition' <- typeSystemDefinition + pure $ TypeSystemDefinition definition' location + typeSystemExtension' = do + location <- getLocation + definition' <- typeSystemExtension + pure $ TypeSystemExtension definition' location + +getLocation :: Parser Location +getLocation = fromSourcePosition <$> getSourcePos + where + fromSourcePosition SourcePos{..} = + Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn) + wordFromPosition = fromIntegral . unPos executableDefinition :: Parser ExecutableDefinition executableDefinition = DefinitionOperation <$> operationDefinition diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 0c29368..76d1fe7 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -255,10 +255,10 @@ 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 = (operations, HashMap.insert name fragment fragments') diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs new file mode 100644 index 0000000..6df97a1 --- /dev/null +++ b/src/Language/GraphQL/Validate.hs @@ -0,0 +1,89 @@ +{- 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 LambdaCase #-} + +module Language.GraphQL.Validate + ( Error(..) + , Path(..) + , document + , module Language.GraphQL.Validate.Rules + ) where + +import Control.Monad.Trans.Reader (Reader, asks, 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.Validate.Rules + +data Context m = Context + { ast :: Document + , schema :: Schema m + , rules :: [Rule] + } + +type ValidateT m = Reader (Context m) (Seq Error) + +data Path + = Segment Text + | Index Int + deriving (Eq, Show) + +data Error = Error + { message :: String + , locations :: [Location] + , path :: [Path] + } deriving (Eq, Show) + +document :: forall m. Schema m -> [Rule] -> Document -> Seq Error +document schema' rules' document' = + runReader (foldrM go Seq.empty document') context + where + context = Context + { ast = document' + , schema = schema' + , rules = rules' + } + go definition' accumulator = (accumulator ><) <$> definition definition' + +definition :: forall m. Definition -> ValidateT m +definition = \case + 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 + +executableDefinition :: forall m. ExecutableDefinition -> ValidateT m +executableDefinition (DefinitionOperation definition') = + operationDefinition definition' +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 + +fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m +fragmentDefinition _fragment = pure Seq.empty diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs new file mode 100644 index 0000000..bc754c2 --- /dev/null +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -0,0 +1,25 @@ +{- 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/. -} + +module Language.GraphQL.Validate.Rules + ( Rule(..) + , executableDefinitionsRule + , specifiedRules + ) where + +import Language.GraphQL.AST.Document + +newtype Rule + = DefinitionRule (Definition -> Maybe String) + +specifiedRules :: [Rule] +specifiedRules = + [ executableDefinitionsRule + ] + +executableDefinitionsRule :: Rule +executableDefinitionsRule = DefinitionRule go + where + go (ExecutableDefinition _definition _) = Nothing + go _ = Just "Definition must be OperationDefinition or FragmentDefinition." diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index e463996..f59e5a9 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -129,10 +129,11 @@ spec = describe "Parser" $ do it "parses schema extension with an operation type and directive" $ let newDirective = Directive "newDirective" [] - testSchemaExtension = TypeSystemExtension - $ SchemaExtension + schemaExtension = SchemaExtension $ SchemaOperationExtension [newDirective] $ OperationTypeDefinition Query "Query" :| [] + testSchemaExtension = TypeSystemExtension schemaExtension + $ Location 1 1 query = [r|extend schema @newDirective { query: Query }|] in parse document "" query `shouldParse` (testSchemaExtension :| []) diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs new file mode 100644 index 0000000..f84322d --- /dev/null +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -0,0 +1,171 @@ +{- 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 QuasiQuotes #-} + +module Language.GraphQL.ValidateSpec + ( spec + ) where + +import Data.Sequence (Seq(..)) +import qualified Data.Sequence as Seq +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Language.GraphQL.AST as AST +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, describe, it, shouldBe) +import Text.Megaparsec (parse) +import Text.RawString.QQ (r) + +schema :: Schema IO +schema = Schema + { query = queryType + , mutation = Nothing + , subscription = Nothing + } + +queryType :: ObjectType IO +queryType = ObjectType "Query" Nothing [] + $ HashMap.singleton "dog" dogResolver + where + dogField = Field Nothing (Out.NamedObjectType dogType) mempty + dogResolver = ValueResolver dogField $ pure Null + +dogCommandType :: EnumType +dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList + [ ("SIT", EnumValue Nothing) + , ("DOWN", EnumValue Nothing) + , ("HEEL", EnumValue Nothing) + ] + +dogType :: ObjectType IO +dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList + [ ("name", nameResolver) + , ("nickname", nicknameResolver) + , ("barkVolume", barkVolumeResolver) + , ("doesKnowCommand", doesKnowCommandResolver) + , ("isHousetrained", isHousetrainedResolver) + , ("owner", ownerResolver) + ] + where + nameField = Field Nothing (Out.NonNullScalarType string) mempty + nameResolver = ValueResolver nameField $ pure "Name" + nicknameField = Field Nothing (Out.NamedScalarType string) mempty + nicknameResolver = ValueResolver nicknameField $ pure "Nickname" + barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty + barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3 + doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean) + $ HashMap.singleton "dogCommand" + $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing + doesKnowCommandResolver = ValueResolver doesKnowCommandField + $ pure $ Boolean True + isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean) + $ HashMap.singleton "atOtherHomes" + $ In.Argument Nothing (In.NamedScalarType boolean) Nothing + isHousetrainedResolver = ValueResolver isHousetrainedField + $ pure $ Boolean True + ownerField = Field Nothing (Out.NamedObjectType humanType) mempty + ownerResolver = ValueResolver ownerField $ pure Null + +sentientType :: InterfaceType IO +sentientType = InterfaceType "Sentient" Nothing [] + $ HashMap.singleton "name" + $ Field Nothing (Out.NonNullScalarType string) mempty + +petType :: InterfaceType IO +petType = InterfaceType "Pet" Nothing [] + $ HashMap.singleton "name" + $ Field Nothing (Out.NonNullScalarType string) mempty +{- +alienType :: ObjectType IO +alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList + [ ("name", nameResolver) + , ("homePlanet", homePlanetResolver) + ] + where + nameField = Field Nothing (Out.NonNullScalarType string) mempty + nameResolver = ValueResolver nameField $ pure "Name" + homePlanetField = + Field Nothing (Out.NamedScalarType string) mempty + homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet" +-} +humanType :: ObjectType IO +humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList + [ ("name", nameResolver) + , ("pets", petsResolver) + ] + where + nameField = Field Nothing (Out.NonNullScalarType string) mempty + nameResolver = ValueResolver nameField $ pure "Name" + petsField = + Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty + petsResolver = ValueResolver petsField $ pure $ List [] +{- +catCommandType :: EnumType +catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList + [ ("JUMP", EnumValue Nothing) + ] + +catType :: ObjectType IO +catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList + [ ("name", nameResolver) + , ("nickname", nicknameResolver) + , ("doesKnowCommand", doesKnowCommandResolver) + , ("meowVolume", meowVolumeResolver) + ] + where + nameField = Field Nothing (Out.NonNullScalarType string) mempty + nameResolver = ValueResolver nameField $ pure "Name" + nicknameField = Field Nothing (Out.NamedScalarType string) mempty + nicknameResolver = ValueResolver nicknameField $ pure "Nickname" + doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean) + $ HashMap.singleton "catCommand" + $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing + doesKnowCommandResolver = ValueResolver doesKnowCommandField + $ pure $ Boolean True + meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty + meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2 + +catOrDogType :: UnionType IO +catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType] + +dogOrHumanType :: UnionType IO +dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType] + +humanOrAlienType :: UnionType IO +humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType] +-} +validate :: Text -> Seq Error +validate queryString = + case parse AST.document "" queryString of + Left _ -> Seq.empty + Right ast -> document schema specifiedRules ast + +spec :: Spec +spec = + describe "document" $ + it "rejects type definitions" $ + let queryString = [r| + query getDogName { + dog { + name + color + } + } + + extend type Dog { + color: String + } + |] + expected = Error + { message = + "Definition must be OperationDefinition or FragmentDefinition." + , locations = [AST.Location 9 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected