aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Language/GraphQL/AST.hs4
-rw-r--r--src/Language/GraphQL/AST/DirectiveLocation.hs10
-rw-r--r--src/Language/GraphQL/AST/Document.hs13
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs14
-rw-r--r--src/Language/GraphQL/AST/Parser.hs45
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs4
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs24
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs36
-rw-r--r--src/Language/GraphQL/Type/In.hs4
-rw-r--r--src/Language/GraphQL/Type/Internal.hs39
-rw-r--r--src/Language/GraphQL/Type/Schema.hs4
-rw-r--r--src/Language/GraphQL/Validate.hs78
-rw-r--r--src/Language/GraphQL/Validate/Rules.hs212
-rw-r--r--src/Language/GraphQL/Validate/Validation.hs54
-rw-r--r--src/Test/Hspec/GraphQL.hs9
15 files changed, 404 insertions, 146 deletions
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
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 09:37:04 +0000