Validate fragments don't form cycles

5 files changed, 128 insertions, 21 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 29710bb..378814d 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -19,6 +19,7 @@ and this project adheres to
   - `fragmentSpreadTargetDefinedRule`
   - `fragmentSpreadTypeExistenceRule`
   - `noUnusedFragmentsRule`
+  - `noFragmentCyclesRule`
 - `AST.Document.Field`.
 - `AST.Document.FragmentSpread`.
 - `AST.Document.InlineFragment`.
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 6a079f1..f5fdf9f 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -14,6 +14,7 @@ module Language.GraphQL.Validate.Rules
     , fragmentSpreadTargetDefinedRule
     , fragmentSpreadTypeExistenceRule
     , loneAnonymousOperationRule
+    , noFragmentCyclesRule
     , noUnusedFragmentsRule
     , singleFieldSubscriptionsRule
     , specifiedRules
@@ -23,11 +24,15 @@ module Language.GraphQL.Validate.Rules
 
 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 Control.Monad.Trans.Reader (ReaderT, asks)
+import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import Data.Bifunctor (first)
 import Data.Foldable (find)
 import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict (HashMap)
 import qualified Data.HashSet as HashSet
+import Data.List (sortBy)
+import Data.Ord (comparing)
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.GraphQL.AST.Document
@@ -50,6 +55,7 @@ specifiedRules =
     , fragmentsOnCompositeTypesRule
     , noUnusedFragmentsRule
     , fragmentSpreadTargetDefinedRule
+    , noFragmentCyclesRule
     ]
 
 -- | Definition must be OperationDefinition or FragmentDefinition.
@@ -382,3 +388,62 @@ noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment ->
     evaluateSelections :: Foldable t => Name -> Bool -> t Selection -> Bool
     evaluateSelections fragName accumulator selections =
         foldr (evaluateSelection fragName) accumulator selections
+
+-- | The graph of fragment spreads must not form any cycles including spreading
+-- itself. Otherwise an operation could infinitely spread or infinitely execute
+-- on cycles in the underlying data.
+noFragmentCyclesRule :: forall m. Rule m
+noFragmentCyclesRule = FragmentDefinitionRule $ \case
+    FragmentDefinition fragmentName _ _ selections location -> do
+        state <- evalStateT (collectFields selections)
+            (0, fragmentName)
+        let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)
+        case reverse spreadPath of
+            x : _ | x == fragmentName -> pure $ Error
+                { message = concat
+                    [ "Cannot spread fragment \""
+                    , Text.unpack fragmentName
+                    , "\" within itself (via "
+                    , Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath
+                    , ")."
+                    ]
+                , locations = [location]
+                , path = []
+                }
+            _ -> lift Nothing
+  where
+    collectFields :: Traversable t
+        => forall m
+        . t Selection
+        -> StateT (Int, Name) (ReaderT (Validation m) Maybe) (HashMap Name Int)
+    collectFields selectionSet = foldM forEach HashMap.empty selectionSet
+    forEach accumulator = \case
+        FieldSelection fieldSelection -> forField accumulator fieldSelection
+        InlineFragmentSelection fragmentSelection ->
+            forInline accumulator fragmentSelection
+        FragmentSpreadSelection fragmentSelection ->
+            forSpread accumulator fragmentSelection
+    forSpread accumulator (FragmentSpread fragmentName _ _) = do
+        firstFragmentName <- gets snd
+        modify $ first (+ 1)
+        lastIndex <- gets fst
+        let newAccumulator = HashMap.insert fragmentName lastIndex accumulator
+        let inVisitetFragment =HashMap.member fragmentName accumulator
+        if fragmentName == firstFragmentName || inVisitetFragment
+            then pure newAccumulator
+            else collectFromSpread fragmentName newAccumulator
+    forInline accumulator (InlineFragment _ _ selections _) =
+        (accumulator <>) <$> collectFields selections
+    forField accumulator (Field _ _ _ _ selections _) =
+        (accumulator <>) <$> collectFields selections
+    findFragmentDefinition n (ExecutableDefinition executableDefinition) Nothing
+        | DefinitionFragment fragmentDefinition <- executableDefinition
+        , FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition
+        , fragmentName == n = Just fragmentDefinition
+    findFragmentDefinition _ _ accumulator = accumulator
+    collectFromSpread _fragmentName accumulator = do
+        ast' <- lift $ asks ast
+        case foldr (findFragmentDefinition _fragmentName) Nothing ast' of
+            Nothing -> pure accumulator
+            Just (FragmentDefinition _ _ _ selections _) ->
+                (accumulator <>) <$> collectFields selections
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 8fbb55b..7b67824 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -3,6 +3,7 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Language.GraphQL.ExecuteSpec
     ( spec
     ) where
@@ -10,10 +11,11 @@ module Language.GraphQL.ExecuteSpec
 import Control.Exception (SomeException)
 import Data.Aeson ((.=))
 import qualified Data.Aeson as Aeson
+import Data.Aeson.Types (emptyObject)
 import Data.Conduit
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST (Name)
+import Language.GraphQL.AST (Document, Name)
 import Language.GraphQL.AST.Parser (document)
 import Language.GraphQL.Error
 import Language.GraphQL.Execute
@@ -21,6 +23,7 @@ import Language.GraphQL.Type as Type
 import Language.GraphQL.Type.Out as Out
 import Test.Hspec (Spec, context, describe, it, shouldBe)
 import Text.Megaparsec (parse)
+import Text.RawString.QQ (r)
 
 schema :: Schema (Either SomeException)
 schema = Schema
@@ -71,9 +74,31 @@ quoteType = Out.ObjectType "Quote" Nothing []
     quoteField =
         Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
 
+type EitherStreamOrValue = Either
+    (ResponseEventStream (Either SomeException) Aeson.Value)
+    (Response Aeson.Value)
+
+execute' :: Document -> Either SomeException EitherStreamOrValue
+execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
+
 spec :: Spec
 spec =
     describe "execute" $ do
+        it "rejects recursive fragments" $
+            let sourceQuery = [r|
+              {
+                ...cyclicFragment
+              }
+
+              fragment cyclicFragment on Query {
+                ...cyclicFragment
+              }
+            |]
+                expected = Response emptyObject mempty
+                Right (Right actual) = either (pure . parseError) execute'
+                    $ parse document "" sourceQuery
+             in actual `shouldBe` expected
+
         context "Query" $ do
             it "skips unknown fields" $
                 let data'' = Aeson.object
@@ -82,7 +107,6 @@ spec =
                             ]
                         ]
                     expected = Response data'' mempty
-                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
                     Right (Right actual) = either (pure . parseError) execute'
                         $ parse document "" "{ philosopher { firstName surname } }"
                 in actual `shouldBe` expected
@@ -94,7 +118,6 @@ spec =
                             ]
                         ]
                     expected = Response data'' mempty
-                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
                     Right (Right actual) = either (pure . parseError) execute'
                         $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
                 in actual `shouldBe` expected
@@ -106,7 +129,6 @@ spec =
                             ]
                         ]
                     expected = Response data'' mempty
-                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
                     Right (Left stream) = either (pure . parseError) execute'
                         $ parse document "" "subscription { newQuote { quote } }"
                     Right (Just actual) = runConduit $ stream .| await
diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
index 10b6688..c6d8487 100644
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -393,3 +393,37 @@ spec =
                     , path = []
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects spreads that form cycles" $
+            let queryString = [r|
+              {
+                dog {
+                  ...nameFragment
+                }
+              }
+              fragment nameFragment on Dog {
+                name
+                ...barkVolumeFragment
+              }
+              fragment barkVolumeFragment on Dog {
+                barkVolume
+                ...nameFragment
+              }
+            |]
+                error1 = Error
+                    { message =
+                        "Cannot spread fragment \"barkVolumeFragment\" within \
+                        \itself (via barkVolumeFragment -> nameFragment -> \
+                        \barkVolumeFragment)."
+                    , locations = [AST.Location 11 15]
+                    , path = []
+                    }
+                error2 = Error
+                    { message =
+                        "Cannot spread fragment \"nameFragment\" within itself \
+                        \(via nameFragment -> barkVolumeFragment -> \
+                        \nameFragment)."
+                    , locations = [AST.Location 7 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.fromList [error1, error2]
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 216ae21..27b08a2 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -178,21 +178,6 @@ spec = do
                         ]
              in actual `shouldResolveTo` expected
 
-        it "rejects recursive fragments" $ do
-            let expected = HashMap.singleton "data" $ Aeson.object []
-                sourceQuery = [r|
-              {
-                ...circumferenceFragment
-              }
-
-              fragment circumferenceFragment on Hat {
-                ...circumferenceFragment
-              }
-            |]
-
-            actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            actual `shouldResolveTo` expected
-
         it "considers type condition" $ do
             let sourceQuery = [r|
               {