Validate fragments don't form cycles

This commit is contained in:
Eugen Wissner 2020-09-11 08:03:49 +02:00
parent c2c57b6363
commit 08998dbd93
5 changed files with 128 additions and 21 deletions

View File

@ -19,6 +19,7 @@ and this project adheres to
- `fragmentSpreadTargetDefinedRule` - `fragmentSpreadTargetDefinedRule`
- `fragmentSpreadTypeExistenceRule` - `fragmentSpreadTypeExistenceRule`
- `noUnusedFragmentsRule` - `noUnusedFragmentsRule`
- `noFragmentCyclesRule`
- `AST.Document.Field`. - `AST.Document.Field`.
- `AST.Document.FragmentSpread`. - `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`. - `AST.Document.InlineFragment`.

View File

@ -14,6 +14,7 @@ module Language.GraphQL.Validate.Rules
, fragmentSpreadTargetDefinedRule , fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule , fragmentSpreadTypeExistenceRule
, loneAnonymousOperationRule , loneAnonymousOperationRule
, noFragmentCyclesRule
, noUnusedFragmentsRule , noUnusedFragmentsRule
, singleFieldSubscriptionsRule , singleFieldSubscriptionsRule
, specifiedRules , specifiedRules
@ -23,11 +24,15 @@ module Language.GraphQL.Validate.Rules
import Control.Monad (foldM) import Control.Monad (foldM)
import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (asks) import Control.Monad.Trans.Reader (ReaderT, asks)
import Control.Monad.Trans.State (evalStateT, gets, modify) import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Data.Bifunctor (first)
import Data.Foldable (find) import Data.Foldable (find)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
@ -50,6 +55,7 @@ specifiedRules =
, fragmentsOnCompositeTypesRule , fragmentsOnCompositeTypesRule
, noUnusedFragmentsRule , noUnusedFragmentsRule
, fragmentSpreadTargetDefinedRule , fragmentSpreadTargetDefinedRule
, noFragmentCyclesRule
] ]
-- | Definition must be OperationDefinition or FragmentDefinition. -- | Definition must be OperationDefinition or FragmentDefinition.
@ -382,3 +388,62 @@ noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment ->
evaluateSelections :: Foldable t => Name -> Bool -> t Selection -> Bool evaluateSelections :: Foldable t => Name -> Bool -> t Selection -> Bool
evaluateSelections fragName accumulator selections = evaluateSelections fragName accumulator selections =
foldr (evaluateSelection 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

View File

@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Language.GraphQL.ExecuteSpec module Language.GraphQL.ExecuteSpec
( spec ( spec
) where ) where
@ -10,10 +11,11 @@ module Language.GraphQL.ExecuteSpec
import Control.Exception (SomeException) import Control.Exception (SomeException)
import Data.Aeson ((.=)) import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Aeson.Types (emptyObject)
import Data.Conduit import Data.Conduit
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as 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.AST.Parser (document)
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Execute import Language.GraphQL.Execute
@ -21,6 +23,7 @@ import Language.GraphQL.Type as Type
import Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Out as Out
import Test.Hspec (Spec, context, describe, it, shouldBe) import Test.Hspec (Spec, context, describe, it, shouldBe)
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
import Text.RawString.QQ (r)
schema :: Schema (Either SomeException) schema :: Schema (Either SomeException)
schema = Schema schema = Schema
@ -71,9 +74,31 @@ quoteType = Out.ObjectType "Quote" Nothing []
quoteField = quoteField =
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty 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 :: Spec
spec = spec =
describe "execute" $ do 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 context "Query" $ do
it "skips unknown fields" $ it "skips unknown fields" $
let data'' = Aeson.object let data'' = Aeson.object
@ -82,7 +107,6 @@ spec =
] ]
] ]
expected = Response data'' mempty expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
Right (Right actual) = either (pure . parseError) execute' Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName surname } }" $ parse document "" "{ philosopher { firstName surname } }"
in actual `shouldBe` expected in actual `shouldBe` expected
@ -94,7 +118,6 @@ spec =
] ]
] ]
expected = Response data'' mempty expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
Right (Right actual) = either (pure . parseError) execute' Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }" $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
in actual `shouldBe` expected in actual `shouldBe` expected
@ -106,7 +129,6 @@ spec =
] ]
] ]
expected = Response data'' mempty expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
Right (Left stream) = either (pure . parseError) execute' Right (Left stream) = either (pure . parseError) execute'
$ parse document "" "subscription { newQuote { quote } }" $ parse document "" "subscription { newQuote { quote } }"
Right (Just actual) = runConduit $ stream .| await Right (Just actual) = runConduit $ stream .| await

View File

@ -393,3 +393,37 @@ spec =
, path = [] , path = []
} }
in validate queryString `shouldBe` Seq.singleton expected 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]

View File

@ -178,21 +178,6 @@ spec = do
] ]
in actual `shouldResolveTo` expected 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 it "considers type condition" $ do
let sourceQuery = [r| let sourceQuery = [r|
{ {