summaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST/Document.hs6
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs3
-rw-r--r--src/Language/GraphQL/AST/Parser.hs37
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs4
-rw-r--r--src/Language/GraphQL/Validate.hs89
-rw-r--r--src/Language/GraphQL/Validate/Rules.hs25
6 files changed, 154 insertions, 10 deletions
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."
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-27 08:00:07 +0000