1 files changed, 198 insertions, 14 deletions

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