From 08998dbd935e65aab10ff53c249cb214af2522f2 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 11 Sep 2020 08:03:49 +0200 Subject: [PATCH] Validate fragments don't form cycles --- CHANGELOG.md | 1 + src/Language/GraphQL/Validate/Rules.hs | 69 +++++++++++++++++++++++++- tests/Language/GraphQL/ExecuteSpec.hs | 30 +++++++++-- tests/Language/GraphQL/ValidateSpec.hs | 34 +++++++++++++ tests/Test/FragmentSpec.hs | 15 ------ 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| {