diff --git a/CHANGELOG.md b/CHANGELOG.md index b9fc93f..893f7ab 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,28 +6,36 @@ The format is based on and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [Unreleased] +### Changed +- Added location information to `AST.Document.Selection.FragmentSpread`. + +### Added +- `Validate.Validation.Rule`: `SelectionRule` constructor. +- `Validate.Rules`: `fragmentSpreadTargetDefinedRule`. + ## [0.10.0.0] - 2020-08-29 -## Changed +### Changed - `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`. - The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was moved to `OperationDefinition` and `FragmentDefinition` since these are the actual elements that have a location in the document. - `Validate.Rules` get the whole validation context (AST and schema). -## Added +### 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 +### Fixed - Location of a parse error is returned in a singleton array with key `locations`. - Parsing comments in the front of definitions. - Some missing labels were added to the parsers, some labels were fixed to refer to the AST nodes being parsed. -## Added +### Added - `AST` reexports `AST.Parser`. - `AST.Document.Location` is a token location as a line and column pair. - `Execute` reexports `Execute.Coerce`. @@ -43,7 +51,7 @@ and this project adheres to - `Test.Hspec.GraphQL` contains some test helpers. - `Validate` contains the validator and standard rules. -## Changed +### Changed - `Type.Out.Resolver`: Interface fields don't have resolvers, object fields have value resolvers, root subscription type resolvers need an additional resolver that creates an event stream. `Resolver` represents these differences @@ -67,7 +75,7 @@ and this project adheres to - The constraint of the base monad was changed to `MonadCatch` (and it implies `MonadThrow`). -## Removed +### Removed - `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver` represents possible resolver configurations. - `Execute.executeWithName`. `Execute.execute` takes the operation name and @@ -334,6 +342,7 @@ and this project adheres to ### Added - Data types for the GraphQL language. +[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.10.0.0...HEAD [0.10.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.9.0.0...v0.10.0.0 [0.9.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...v0.9.0.0 [0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0 diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 72d39bb..3b94e55 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -163,7 +163,7 @@ type SelectionSetOpt = [Selection] -- @ data Selection = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt - | FragmentSpread Name [Directive] + | FragmentSpread Name [Directive] Location | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet deriving (Eq, Show) diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index ba89d36..ec28b86 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -130,7 +130,7 @@ selection formatter = Lazy.Text.append indent' . encodeSelection field incrementIndent alias name args directives' selections encodeSelection (InlineFragment typeCondition directives' selections) = inlineFragment incrementIndent typeCondition directives' selections - encodeSelection (FragmentSpread name directives') = + encodeSelection (FragmentSpread name directives' _) = fragmentSpread incrementIndent name directives' incrementIndent | Pretty indentation <- formatter = Pretty $ indentation + 1 diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 7bc51cb..e97f306 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -400,11 +400,12 @@ argument :: Parser Argument argument = Argument <$> name <* colon <*> value "Argument" fragmentSpread :: Parser Selection -fragmentSpread = FragmentSpread - <$ spread - <*> fragmentName - <*> directives - "FragmentSpread" +fragmentSpread = label "FragmentSpread" $ do + location <- getLocation + _ <- spread + fragmentName' <- fragmentName + directives' <- directives + pure $ FragmentSpread fragmentName' directives' location inlineFragment :: Parser Selection inlineFragment = InlineFragment diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 9c7ad0a..deeb5b9 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -299,7 +299,7 @@ selection (Full.Field alias name arguments' directives' selections) = go arguments (Full.Argument name' value') = inputField arguments name' value' -selection (Full.FragmentSpread name directives') = +selection (Full.FragmentSpread name directives' _) = maybe (Left mempty) (Right . SelectionFragment) <$> do spreadDirectives <- Definition.selection <$> directives directives' fragments' <- gets fragments diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 53dc6f9..6ff1f57 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -15,7 +15,7 @@ module Language.GraphQL.Validate import Control.Monad (foldM) import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader) -import Data.Foldable (foldrM) +import Data.Foldable (fold, foldrM) import Data.Sequence (Seq(..), (><), (|>)) import qualified Data.Sequence as Seq import Language.GraphQL.AST.Document @@ -66,15 +66,41 @@ executableDefinition (DefinitionFragment definition') = operationDefinition :: forall m. OperationDefinition -> ValidateT m operationDefinition operation = - asks rules >>= foldM ruleFilter Seq.empty + let selectionSet = getSelectionSet operation + in visitChildSelections ruleFilter selectionSet where ruleFilter accumulator (OperationDefinitionRule rule) = mapReaderT (runRule accumulator) $ rule operation ruleFilter accumulator _ = pure accumulator + getSelectionSet (SelectionSet selectionSet _) = selectionSet + getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet + +selection :: forall m. Selection -> ValidateT m +selection selection'@FragmentSpread{} = + asks rules >>= foldM ruleFilter Seq.empty + where + ruleFilter accumulator (SelectionRule rule) = + mapReaderT (runRule accumulator) $ rule selection' + ruleFilter accumulator _ = pure accumulator +selection (Field _ _ _ _ selectionSet) = traverseSelectionSet selectionSet +selection (InlineFragment _ _ selectionSet) = traverseSelectionSet selectionSet + +traverseSelectionSet :: Traversable t => forall m. t Selection -> ValidateT m +traverseSelectionSet = fmap fold . traverse selection + +visitChildSelections :: Traversable t + => (Seq Error -> Rule m -> ValidateT m) + -> t Selection + -> ValidateT m +visitChildSelections ruleFilter selectionSet = do + rules' <- asks rules + applied <- foldM ruleFilter Seq.empty rules' + children <- traverseSelectionSet selectionSet + pure $ children >< applied fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m -fragmentDefinition fragment = - asks rules >>= foldM ruleFilter Seq.empty +fragmentDefinition fragment@(FragmentDefinition _ _ _ selectionSet _) = + visitChildSelections ruleFilter selectionSet where ruleFilter accumulator (FragmentDefinitionRule rule) = mapReaderT (runRule accumulator) $ rule fragment diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 690631e..c531753 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -21,6 +21,7 @@ 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 Data.Foldable (find) import qualified Data.HashSet as HashSet import qualified Data.Text as Text import Language.GraphQL.AST.Document @@ -36,6 +37,7 @@ specifiedRules = , loneAnonymousOperationRule , uniqueOperationNamesRule , uniqueFragmentNamesRule + , fragmentSpreadTargetDefinedRule ] -- | Definition must be OperationDefinition or FragmentDefinition. @@ -84,7 +86,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case | Just aliasedName <- alias = pure $ HashSet.insert aliasedName accumulator | otherwise = pure $ HashSet.insert name accumulator - forEach accumulator (FragmentSpread fragmentName directives) + forEach accumulator (FragmentSpread fragmentName directives _) | any skip directives = pure accumulator | otherwise = do inVisitetFragments <- gets $ HashSet.member fragmentName @@ -192,6 +194,13 @@ viewOperation definition Just operationDefinition viewOperation _ = Nothing +viewFragment :: Definition -> Maybe FragmentDefinition +viewFragment definition + | ExecutableDefinition executableDefinition <- definition + , DefinitionFragment fragmentDefinition <- executableDefinition = + Just fragmentDefinition +viewFragment _ = Nothing + -- | Fragment definitions are referenced in fragment spreads by name. To avoid -- ambiguity, each fragment’s name must be unique within a document. -- @@ -208,8 +217,32 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case , "\"." ] filterByName thisName definition accumulator - | ExecutableDefinition executableDefinition <- definition - , DefinitionFragment fragmentDefinition <- executableDefinition + | Just fragmentDefinition <- viewFragment definition , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition , thisName == thatName = thatLocation : accumulator | otherwise = accumulator + +-- | Named fragment spreads must refer to fragments defined within the document. +-- It is a validation error if the target of a spread is not defined. +fragmentSpreadTargetDefinedRule :: forall m. Rule m +fragmentSpreadTargetDefinedRule = SelectionRule $ \case + FragmentSpread fragmentName _ location -> do + ast' <- asks ast + case find (findTarget fragmentName) ast' of + Nothing -> pure $ Error + { message = error' fragmentName + , locations = [location] + , path = [] + } + Just _ -> lift Nothing + _ -> lift Nothing + where + error' fragmentName = concat + [ "Fragment target \"" + , Text.unpack fragmentName + , "\" is undefined." + ] + findTarget thisName (viewFragment -> Just fragmentDefinition) + | FragmentDefinition thatName _ _ _ _ <- fragmentDefinition + , thisName == thatName = True + findTarget _ _ = False diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index 03bbf33..21640bc 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -49,6 +49,7 @@ data Rule m = DefinitionRule (Definition -> RuleT m) | OperationDefinitionRule (OperationDefinition -> RuleT m) | FragmentDefinitionRule (FragmentDefinition -> RuleT m) + | SelectionRule (Selection -> RuleT m) -- | Monad transformer used by the rules. type RuleT m = ReaderT (Validation m) Maybe Error diff --git a/stack.yaml b/stack.yaml index acffb4d..1bfe114 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.11 +resolver: lts-16.12 packages: - . @@ -6,4 +6,4 @@ packages: extra-deps: [] flags: {} -pvp-bounds: both +pvp-bounds: lower diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index 8f6626b..f8809f9 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -281,3 +281,19 @@ spec = , path = [] } in validate queryString `shouldBe` Seq.singleton expected + + it "rejects the fragment spread without a target" $ + let queryString = [r| + { + dog { + ...undefinedFragment + } + } + |] + expected = Error + { message = + "Fragment target \"undefinedFragment\" is undefined." + , locations = [AST.Location 4 19] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected