Draft the Validation API

7 files changed, 176 insertions, 12 deletions

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