diff --git a/CHANGELOG.md b/CHANGELOG.md index d1b5216..2e45f6d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,7 @@ and this project adheres to ## Added - `Validate.Validation` contains data structures and functions used by the validator and concretet rules. +- `Validate.Rules`: operation validation rules. ## [0.9.0.0] - 2020-07-24 ## Fixed diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index bcc3bf7..53dc6f9 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -66,11 +66,16 @@ executableDefinition (DefinitionFragment definition') = operationDefinition :: forall m. OperationDefinition -> ValidateT m operationDefinition operation = - asks rules >>= foldM (ruleFilter operation) Seq.empty + asks rules >>= foldM ruleFilter Seq.empty where - ruleFilter definition' accumulator (OperationDefinitionRule rule) = - mapReaderT (runRule accumulator) $ rule definition' - ruleFilter _ accumulator _ = pure accumulator + ruleFilter accumulator (OperationDefinitionRule rule) = + mapReaderT (runRule accumulator) $ rule operation + ruleFilter accumulator _ = pure accumulator fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m -fragmentDefinition _fragment = pure Seq.empty +fragmentDefinition fragment = + asks rules >>= foldM ruleFilter Seq.empty + where + ruleFilter accumulator (FragmentDefinitionRule rule) = + mapReaderT (runRule accumulator) $ rule fragment + ruleFilter accumulator _ = pure accumulator diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 4994f5c..690631e 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -13,6 +13,7 @@ module Language.GraphQL.Validate.Rules , loneAnonymousOperationRule , singleFieldSubscriptionsRule , specifiedRules + , uniqueFragmentNamesRule , uniqueOperationNamesRule ) where @@ -34,6 +35,7 @@ specifiedRules = , singleFieldSubscriptionsRule , loneAnonymousOperationRule , uniqueOperationNamesRule + , uniqueFragmentNamesRule ] -- | Definition must be OperationDefinition or FragmentDefinition. @@ -151,32 +153,63 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case -- referred to by its name. uniqueOperationNamesRule :: forall m. Rule m uniqueOperationNamesRule = OperationDefinitionRule $ \case - OperationDefinition _ (Just thisName) _ _ _ thisLocation -> do - ast' <- asks ast - let locations' = foldr (filterByName thisName) [] ast' - if length locations' > 1 && head locations' == thisLocation - then pure $ error' thisName locations' - else lift Nothing + OperationDefinition _ (Just thisName) _ _ _ thisLocation -> + findDuplicates (filterByName thisName) thisLocation (error' thisName) _ -> lift Nothing where - error' operationName locations' = Error - { message = concat - [ "There can be only one operation named \"" - , Text.unpack operationName - , "\"." - ] - , locations = locations' - , path = [] - } + 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 + 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 diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index 2b5365a..03bbf33 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -48,6 +48,7 @@ data Validation m = Validation data Rule m = DefinitionRule (Definition -> RuleT m) | OperationDefinitionRule (OperationDefinition -> RuleT m) + | FragmentDefinitionRule (FragmentDefinition -> RuleT m) -- | Monad transformer used by the rules. type RuleT m = ReaderT (Validation m) Maybe Error diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index a547e21..8f6626b 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -255,3 +255,29 @@ spec = , path = [] } in validate queryString `shouldBe` Seq.singleton expected + + it "rejects fragments with the same name" $ + let queryString = [r| + { + dog { + ...fragmentOne + } + } + + fragment fragmentOne on Dog { + name + } + + fragment fragmentOne on Dog { + owner { + name + } + } + |] + expected = Error + { message = + "There can be only one fragment named \"fragmentOne\"." + , locations = [AST.Location 8 15, AST.Location 12 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected