Draft the Validation API

This commit is contained in:
Eugen Wissner 2020-07-20 21:29:12 +02:00
parent b9d5b1fb1b
commit 44d506d4b5
11 changed files with 355 additions and 15 deletions

View File

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: ca820b1bb2b81ffca4a3e2563bfa2be5381d80eaf4085595e07cf7db2aa3c6a9 -- hash: ba234bcfff46df053a3466359e32682c4592b88894911ecbe78bd00fa00929b5
name: graphql name: graphql
version: 0.8.0.0 version: 0.8.0.0
@ -51,6 +51,7 @@ library
Language.GraphQL.Type.In Language.GraphQL.Type.In
Language.GraphQL.Type.Out Language.GraphQL.Type.Out
Language.GraphQL.Type.Schema Language.GraphQL.Type.Schema
Language.GraphQL.Validate
Test.Hspec.GraphQL Test.Hspec.GraphQL
other-modules: other-modules:
Language.GraphQL.Execute.Execution Language.GraphQL.Execute.Execution
@ -58,6 +59,7 @@ library
Language.GraphQL.Execute.Transform Language.GraphQL.Execute.Transform
Language.GraphQL.Type.Definition Language.GraphQL.Type.Definition
Language.GraphQL.Type.Internal Language.GraphQL.Type.Internal
Language.GraphQL.Validate.Rules
hs-source-dirs: hs-source-dirs:
src src
build-depends: build-depends:
@ -86,6 +88,7 @@ test-suite tasty
Language.GraphQL.Execute.CoerceSpec Language.GraphQL.Execute.CoerceSpec
Language.GraphQL.ExecuteSpec Language.GraphQL.ExecuteSpec
Language.GraphQL.Type.OutSpec Language.GraphQL.Type.OutSpec
Language.GraphQL.ValidateSpec
Test.DirectiveSpec Test.DirectiveSpec
Test.FragmentSpec Test.FragmentSpec
Test.KitchenSinkSpec Test.KitchenSinkSpec

View File

@ -47,6 +47,7 @@ library:
- Language.GraphQL.Execute.Transform - Language.GraphQL.Execute.Transform
- Language.GraphQL.Type.Definition - Language.GraphQL.Type.Definition
- Language.GraphQL.Type.Internal - Language.GraphQL.Type.Internal
- Language.GraphQL.Validate.Rules
tests: tests:
tasty: tasty:

View File

@ -16,6 +16,7 @@ import Data.Text (Text)
import Language.GraphQL.AST import Language.GraphQL.AST
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Execute import Language.GraphQL.Execute
import qualified Language.GraphQL.Validate as Validate
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
@ -39,9 +40,16 @@ graphqlSubs :: MonadCatch m
graphqlSubs schema operationName variableValues document' = graphqlSubs schema operationName variableValues document' =
case parse document "" document' of case parse document "" document' of
Left errorBundle -> pure . formatResponse <$> parseError errorBundle Left errorBundle -> pure . formatResponse <$> parseError errorBundle
Right parsed -> fmap formatResponse Right parsed ->
<$> execute schema operationName variableValues 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 where
validate = Validate.document schema Validate.specifiedRules
formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data'' formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''
formatResponse (Response data'' errors') = HashMap.fromList formatResponse (Response data'' errors') = HashMap.fromList
[ ("data", data'') [ ("data", data'')
@ -53,6 +61,18 @@ graphqlSubs schema operationName variableValues document' =
[ ("message", Aeson.toJSON message) [ ("message", Aeson.toJSON message)
, ("locations", Aeson.listValue fromLocation locations) , ("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 fromLocation Location{..} = Aeson.object
[ ("line", Aeson.toJSON line) [ ("line", Aeson.toJSON line)
, ("column", Aeson.toJSON column) , ("column", Aeson.toJSON column)

View File

@ -69,9 +69,9 @@ type Document = NonEmpty Definition
-- | All kinds of definitions that can occur in a GraphQL document. -- | All kinds of definitions that can occur in a GraphQL document.
data Definition data Definition
= ExecutableDefinition ExecutableDefinition = ExecutableDefinition ExecutableDefinition Location
| TypeSystemDefinition TypeSystemDefinition | TypeSystemDefinition TypeSystemDefinition Location
| TypeSystemExtension TypeSystemExtension | TypeSystemExtension TypeSystemExtension Location
deriving (Eq, Show) deriving (Eq, Show)
-- | Top-level definition of a document, either an operation or a fragment. -- | Top-level definition of a document, either an operation or a fragment.

View File

@ -50,7 +50,8 @@ document formatter defs
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
where where
encodeDocument = foldr executableDefinition [] defs encodeDocument = foldr executableDefinition [] defs
executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc executableDefinition (ExecutableDefinition x _) acc =
definition formatter x : acc
executableDefinition _ acc = acc executableDefinition _ acc = acc
-- | Converts a t'ExecutableDefinition' into a string. -- | Converts a t'ExecutableDefinition' into a string.

View File

@ -1,5 +1,6 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | @GraphQL@ document parser. -- | @GraphQL@ document parser.
module Language.GraphQL.AST.Parser module Language.GraphQL.AST.Parser
@ -19,7 +20,15 @@ import Language.GraphQL.AST.DirectiveLocation
) )
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import Language.GraphQL.AST.Lexer 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. -- | Parser for the GraphQL documents.
document :: Parser Document document :: Parser Document
@ -28,10 +37,30 @@ document = unicodeBOM
*> lexeme (NonEmpty.some definition) *> lexeme (NonEmpty.some definition)
definition :: Parser Definition definition :: Parser Definition
definition = ExecutableDefinition <$> executableDefinition definition = executableDefinition'
<|> TypeSystemDefinition <$> typeSystemDefinition <|> typeSystemDefinition'
<|> TypeSystemExtension <$> typeSystemExtension <|> typeSystemExtension'
<?> "Definition" <?> "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 :: Parser ExecutableDefinition
executableDefinition = DefinitionOperation <$> operationDefinition executableDefinition = DefinitionOperation <$> operationDefinition

View File

@ -255,10 +255,10 @@ defragment ast =
in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
where where
defragment' definition (operations, fragments') defragment' definition (operations, fragments')
| (Full.ExecutableDefinition executable) <- definition | (Full.ExecutableDefinition executable _) <- definition
, (Full.DefinitionOperation operation') <- executable = , (Full.DefinitionOperation operation') <- executable =
(transform operation' : operations, fragments') (transform operation' : operations, fragments')
| (Full.ExecutableDefinition executable) <- definition | (Full.ExecutableDefinition executable _) <- definition
, (Full.DefinitionFragment fragment) <- executable , (Full.DefinitionFragment fragment) <- executable
, (Full.FragmentDefinition name _ _ _) <- fragment = , (Full.FragmentDefinition name _ _ _) <- fragment =
(operations, HashMap.insert name fragment fragments') (operations, HashMap.insert name fragment fragments')

View File

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

View File

@ -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."

View File

@ -129,10 +129,11 @@ spec = describe "Parser" $ do
it "parses schema extension with an operation type and directive" $ it "parses schema extension with an operation type and directive" $
let newDirective = Directive "newDirective" [] let newDirective = Directive "newDirective" []
testSchemaExtension = TypeSystemExtension schemaExtension = SchemaExtension
$ SchemaExtension
$ SchemaOperationExtension [newDirective] $ SchemaOperationExtension [newDirective]
$ OperationTypeDefinition Query "Query" :| [] $ OperationTypeDefinition Query "Query" :| []
testSchemaExtension = TypeSystemExtension schemaExtension
$ Location 1 1
query = [r|extend schema @newDirective { query: Query }|] query = [r|extend schema @newDirective { query: Query }|]
in parse document "" query `shouldParse` (testSchemaExtension :| []) in parse document "" query `shouldParse` (testSchemaExtension :| [])

View File

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