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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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" $
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 :| [])

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