diff --git a/CHANGELOG.md b/CHANGELOG.md index 65c86f4..2e74142 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,13 +8,18 @@ and this project adheres to ## [Unreleased] ### Changed -- Added location information to `AST.Document.Selection`. +- `AST.Document.Selection` wraps additional new types: `FragmentSpread` + and `InlineFragment`. Thus validation rules can be more concise. ### Added -- `Validate.Validation.Rule`: `SelectionRule` constructor. +- `Validate.Validation.Rule`: `SelectionRule`, `FragmentRule` and + `FragmentSpreadRule` constructors. - `Validate.Rules`: + - `fragmentsOnCompositeTypesRule` - `fragmentSpreadTargetDefinedRule` - `fragmentSpreadTypeExistenceRule` +- `AST.Document.FragmentSpread`. +- `AST.Document.InlineFragment`. ### Fixed - Collecting existing types from the schema considers subscriptions. diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index f780a9d..5cfadc5 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -17,7 +17,9 @@ module Language.GraphQL.AST.Document , ExecutableDefinition(..) , FieldDefinition(..) , FragmentDefinition(..) + , FragmentSpread(..) , ImplementsInterfaces(..) + , InlineFragment(..) , InputValueDefinition(..) , Location(..) , Name @@ -132,7 +134,28 @@ type SelectionSetOpt = [Selection] -- } -- } -- @ +data Selection + = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location + | FragmentSpreadSelection FragmentSpread + | InlineFragmentSelection InlineFragment + deriving (Eq, Show) + +-- Inline fragments don't have any name and the type condition ("on UserType") +-- is optional. -- +-- @ +-- { +-- user { +-- ... on UserType { +-- id +-- name +-- } +-- } +-- @ +data InlineFragment = InlineFragment + (Maybe TypeCondition) [Directive] SelectionSet Location + deriving (Eq, Show) + -- A fragment spread refers to a fragment defined outside the operation and is -- expanded at the execution time. -- @@ -148,23 +171,7 @@ type SelectionSetOpt = [Selection] -- name -- } -- @ --- --- Inline fragments are similar but they don't have any name and the type --- condition ("on UserType") is optional. --- --- @ --- { --- user { --- ... on UserType { --- id --- name --- } --- } --- @ -data Selection - = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location - | FragmentSpread Name [Directive] Location - | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet Location +data FragmentSpread = FragmentSpread Name [Directive] Location deriving (Eq, Show) -- ** Arguments diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 7428365..0757867 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -128,10 +128,10 @@ selection formatter = Lazy.Text.append indent' . encodeSelection where encodeSelection (Field alias name args directives' selections _) = field incrementIndent alias name args directives' selections - encodeSelection (InlineFragment typeCondition directives' selections _) = - inlineFragment incrementIndent typeCondition directives' selections - encodeSelection (FragmentSpread name directives' _) = - fragmentSpread incrementIndent name directives' + encodeSelection (InlineFragmentSelection fragmentSelection) = + inlineFragment incrementIndent fragmentSelection + encodeSelection (FragmentSpreadSelection fragmentSelection) = + fragmentSpread incrementIndent fragmentSelection incrementIndent | Pretty indentation <- formatter = Pretty $ indentation + 1 | otherwise = Minified @@ -172,22 +172,18 @@ argument formatter (Argument name value') -- * Fragments -fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text -fragmentSpread formatter name directives' +fragmentSpread :: Formatter -> FragmentSpread -> Lazy.Text +fragmentSpread formatter (FragmentSpread name directives' _) = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) directives' -inlineFragment :: - Formatter -> - Maybe TypeCondition -> - [Directive] -> - SelectionSet -> - Lazy.Text -inlineFragment formatter tc dirs sels = "... on " - <> Lazy.Text.fromStrict (fold tc) - <> directives formatter dirs +inlineFragment :: Formatter -> InlineFragment -> Lazy.Text +inlineFragment formatter (InlineFragment typeCondition directives' selections _) + = "... on " + <> Lazy.Text.fromStrict (fold typeCondition) + <> directives formatter directives' <> eitherFormat formatter " " mempty - <> selectionSet formatter sels + <> selectionSet formatter selections fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text fragmentDefinition formatter (FragmentDefinition name tc dirs sels _) diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index af82a9e..e68956f 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -377,8 +377,8 @@ selectionSetOpt = listOptIn braces selection "SelectionSet" selection :: Parser Selection selection = field - <|> try fragmentSpread - <|> inlineFragment + <|> FragmentSpreadSelection <$> try fragmentSpread + <|> InlineFragmentSelection <$> inlineFragment "Selection" field :: Parser Selection @@ -400,7 +400,7 @@ arguments = listOptIn parens argument "Arguments" argument :: Parser Argument argument = Argument <$> name <* colon <*> value "Argument" -fragmentSpread :: Parser Selection +fragmentSpread :: Parser FragmentSpread fragmentSpread = label "FragmentSpread" $ do location <- getLocation _ <- spread @@ -408,7 +408,7 @@ fragmentSpread = label "FragmentSpread" $ do directives' <- directives pure $ FragmentSpread fragmentName' directives' location -inlineFragment :: Parser Selection +inlineFragment :: Parser InlineFragment inlineFragment = label "InlineFragment" $ do location <- getLocation _ <- spread diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index b438bdf..e36db55 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -298,8 +298,15 @@ selection (Full.Field alias name arguments' directives' selections _) = where go arguments (Full.Argument name' value') = inputField arguments name' value' +selection (Full.FragmentSpreadSelection fragmentSelection) = + fragmentSpread fragmentSelection +selection (Full.InlineFragmentSelection fragmentSelection) = + inlineFragment fragmentSelection -selection (Full.FragmentSpread name directives' _) = +fragmentSpread + :: Full.FragmentSpread + -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) +fragmentSpread (Full.FragmentSpread name directives' _) = maybe (Left mempty) (Right . SelectionFragment) <$> do spreadDirectives <- Definition.selection <$> directives directives' fragments' <- gets fragments @@ -314,7 +321,11 @@ selection (Full.FragmentSpread name directives' _) = Just fragment -> lift $ pure $ fragment <$ spreadDirectives _ -> lift $ pure Nothing | otherwise -> lift $ pure Nothing -selection (Full.InlineFragment type' directives' selections _) = do + +inlineFragment + :: Full.InlineFragment + -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) +inlineFragment (Full.InlineFragment type' directives' selections _) = do fragmentDirectives <- Definition.selection <$> directives directives' case fragmentDirectives of Nothing -> pure $ Left mempty diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 7a25ce4..1ffa514 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -3,7 +3,6 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE LambdaCase #-} -- | GraphQL validator. module Language.GraphQL.Validate @@ -41,18 +40,15 @@ document schema' rules' document' = go definition' accumulator = (accumulator ><) <$> definition definition' definition :: forall m. Definition -> ValidateT m -definition = \case - definition'@(ExecutableDefinition executableDefinition') -> do - applied <- applyRules definition' - children <- executableDefinition executableDefinition' - pure $ children >< applied - definition' -> applyRules definition' +definition definition' + | ExecutableDefinition executableDefinition' <- definition' + = visitChildSelections ruleFilter + $ executableDefinition executableDefinition' + | otherwise = asks rules >>= foldM ruleFilter Seq.empty where - applyRules definition' = - asks rules >>= foldM (ruleFilter definition') Seq.empty - ruleFilter definition' accumulator (DefinitionRule rule) = + ruleFilter accumulator (DefinitionRule rule) = mapReaderT (runRule accumulator) $ rule definition' - ruleFilter _ accumulator _ = pure accumulator + ruleFilter accumulator _ = pure accumulator runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error) runRule accumulator (Just error') = pure $ accumulator |> error' @@ -67,7 +63,7 @@ executableDefinition (DefinitionFragment definition') = operationDefinition :: forall m. OperationDefinition -> ValidateT m operationDefinition operation = let selectionSet = getSelectionSet operation - in visitChildSelections ruleFilter selectionSet + in visitChildSelections ruleFilter $ traverseSelectionSet selectionSet where ruleFilter accumulator (OperationDefinitionRule rule) = mapReaderT (runRule accumulator) $ rule operation @@ -75,36 +71,54 @@ operationDefinition operation = getSelectionSet (SelectionSet selectionSet _) = selectionSet getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet +visitChildSelections :: forall m + . (Seq Error -> Rule m -> ValidateT m) + -> ValidateT m + -> ValidateT m +visitChildSelections ruleFilter children' = do + rules' <- asks rules + applied <- foldM ruleFilter Seq.empty rules' + children <- children' + pure $ children >< applied + selection :: forall m. Selection -> ValidateT m selection selection' - | FragmentSpread{} <- selection' = - asks rules >>= foldM ruleFilter Seq.empty + | FragmentSpreadSelection fragmentSelection <- selection' = + visitChildSelections ruleFilter $ fragmentSpread fragmentSelection | Field _ _ _ _ selectionSet _ <- selection' = - visitChildSelections ruleFilter selectionSet - | InlineFragment _ _ selectionSet _ <- selection' = - visitChildSelections ruleFilter selectionSet + visitChildSelections ruleFilter $ traverseSelectionSet selectionSet + | InlineFragmentSelection fragmentSelection <- selection' = + visitChildSelections ruleFilter $ inlineFragment fragmentSelection where ruleFilter accumulator (SelectionRule rule) = mapReaderT (runRule accumulator) $ rule selection' ruleFilter accumulator _ = pure accumulator +inlineFragment :: forall m. InlineFragment -> ValidateT m +inlineFragment fragment@(InlineFragment _ _ selections _) = + visitChildSelections ruleFilter $ traverseSelectionSet selections + where + ruleFilter accumulator (FragmentRule _ inlineRule) = + mapReaderT (runRule accumulator) $ inlineRule fragment + ruleFilter accumulator _ = pure accumulator + +fragmentSpread :: forall m. FragmentSpread -> ValidateT m +fragmentSpread fragment = + asks rules >>= foldM ruleFilter Seq.empty + where + ruleFilter accumulator (FragmentSpreadRule rule) = + mapReaderT (runRule accumulator) $ rule fragment + ruleFilter accumulator _ = pure accumulator + 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@(FragmentDefinition _ _ _ selectionSet _) = - visitChildSelections ruleFilter selectionSet + visitChildSelections ruleFilter $ traverseSelectionSet selectionSet where ruleFilter accumulator (FragmentDefinitionRule rule) = mapReaderT (runRule accumulator) $ rule fragment + ruleFilter accumulator (FragmentRule definitionRule _) = + mapReaderT (runRule accumulator) $ definitionRule fragment ruleFilter accumulator _ = pure accumulator diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 78d1901..28e12a3 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -10,6 +10,7 @@ -- | This module contains default rules defined in the GraphQL specification. module Language.GraphQL.Validate.Rules ( executableDefinitionsRule + , fragmentsOnCompositeTypesRule , fragmentSpreadTargetDefinedRule , fragmentSpreadTypeExistenceRule , loneAnonymousOperationRule @@ -46,6 +47,7 @@ specifiedRules = , uniqueFragmentNamesRule , fragmentSpreadTargetDefinedRule , fragmentSpreadTypeExistenceRule + , fragmentsOnCompositeTypesRule ] -- | Definition must be OperationDefinition or FragmentDefinition. @@ -89,24 +91,29 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case errorMessage = "Anonymous Subscription must select only one top level field." collectFields selectionSet = foldM forEach HashSet.empty selectionSet - forEach accumulator (Field alias name _ directives _ _) - | any skip directives = pure accumulator - | Just aliasedName <- alias = pure - $ HashSet.insert aliasedName accumulator - | otherwise = pure $ HashSet.insert name accumulator - forEach accumulator (FragmentSpread fragmentName directives _) + forEach accumulator = \case + Field alias name _ directives _ _ + | any skip directives -> pure accumulator + | Just aliasedName <- alias -> pure + $ HashSet.insert aliasedName accumulator + | otherwise -> pure $ HashSet.insert name accumulator + FragmentSpreadSelection fragmentSelection -> + forSpread accumulator fragmentSelection + InlineFragmentSelection fragmentSelection -> + forInline accumulator fragmentSelection + forSpread accumulator (FragmentSpread fragmentName directives _) | any skip directives = pure accumulator | otherwise = do inVisitetFragments <- gets $ HashSet.member fragmentName if inVisitetFragments then pure accumulator else collectFromSpread fragmentName accumulator - forEach accumulator (InlineFragment typeCondition' directives selectionSet _) + forInline accumulator (InlineFragment maybeType directives selections _) | any skip directives = pure accumulator - | Just typeCondition <- typeCondition' = - collectFromFragment typeCondition selectionSet accumulator + | Just typeCondition <- maybeType = + collectFromFragment typeCondition selections accumulator | otherwise = HashSet.union accumulator - <$> collectFields selectionSet + <$> collectFields selections skip (Directive "skip" [Argument "if" (Boolean True)]) = True skip (Directive "include" [Argument "if" (Boolean False)]) = True skip _ = False @@ -233,7 +240,7 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case -- | 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 +fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case FragmentSpread fragmentName _ location -> do ast' <- asks ast case find (isSpreadTarget fragmentName) ast' of @@ -243,7 +250,6 @@ fragmentSpreadTargetDefinedRule = SelectionRule $ \case , path = [] } Just _ -> lift Nothing - _ -> lift Nothing where error' fragmentName = concat [ "Fragment target \"" @@ -262,27 +268,30 @@ isSpreadTarget _ _ = False -- the query does not validate. fragmentSpreadTypeExistenceRule :: forall m. Rule m fragmentSpreadTypeExistenceRule = SelectionRule $ \case - FragmentSpread fragmentName _ location -> do - ast' <- asks ast - target <- lift $ find (isSpreadTarget fragmentName) ast' - typeCondition <- extractTypeCondition target - types' <- asks types - case HashMap.lookup typeCondition types' of - Nothing -> pure $ Error - { message = spreadError fragmentName typeCondition - , locations = [location] - , path = [] - } - Just _ -> lift Nothing - InlineFragment (Just typeCondition) _ _ location -> do - types' <- asks types - case HashMap.lookup typeCondition types' of - Nothing -> pure $ Error - { message = inlineError typeCondition - , locations = [location] - , path = [] - } - Just _ -> lift Nothing + FragmentSpreadSelection fragmentSelection + | FragmentSpread fragmentName _ location <- fragmentSelection -> do + ast' <- asks ast + target <- lift $ find (isSpreadTarget fragmentName) ast' + typeCondition <- extractTypeCondition target + types' <- asks types + case HashMap.lookup typeCondition types' of + Nothing -> pure $ Error + { message = spreadError fragmentName typeCondition + , locations = [location] + , path = [] + } + Just _ -> lift Nothing + InlineFragmentSelection fragmentSelection + | InlineFragment maybeType _ _ location <- fragmentSelection + , Just typeCondition <- maybeType -> do + types' <- asks types + case HashMap.lookup typeCondition types' of + Nothing -> pure $ Error + { message = inlineError typeCondition + , locations = [location] + , path = [] + } + Just _ -> lift Nothing _ -> lift Nothing where extractTypeCondition (viewFragment -> Just fragmentDefinition) = @@ -301,3 +310,31 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case , Text.unpack typeCondition , "\" which doesn't exist in the schema." ] + +-- | Fragments can only be declared on unions, interfaces, and objects. They are +-- invalid on scalars. They can only be applied on non‐leaf fields. This rule +-- applies to both inline and named fragments. +fragmentsOnCompositeTypesRule :: forall m. Rule m +fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule + where + inlineRule (InlineFragment (Just typeCondition) _ _ location) = + check typeCondition location + inlineRule _ = lift Nothing + definitionRule (FragmentDefinition _ typeCondition _ _ location) = + check typeCondition location + check typeCondition location = do + types' <- asks types + -- Skip unknown types, they are checked by another rule. + _ <- lift $ HashMap.lookup typeCondition types' + case lookupTypeCondition typeCondition types' of + Nothing -> pure $ Error + { message = errorMessage typeCondition + , locations = [location] + , path = [] + } + Just _ -> lift Nothing + errorMessage typeCondition = concat + [ "Fragment cannot condition on non composite type \"" + , Text.unpack typeCondition, + "\"." + ] diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index 21640bc..fb04b76 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -50,6 +50,8 @@ data Rule m | OperationDefinitionRule (OperationDefinition -> RuleT m) | FragmentDefinitionRule (FragmentDefinition -> RuleT m) | SelectionRule (Selection -> RuleT m) + | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m) + | FragmentSpreadRule (FragmentSpread -> 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 1bfe114..7fe786b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.12 +resolver: lts-16.13 packages: - . diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index 990555e..a95c4d6 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -336,3 +336,40 @@ spec = , path = [] } in validate queryString `shouldBe` Seq.singleton expected + + it "rejects fragments on scalar types" $ + let queryString = [r| + { + dog { + ...fragOnScalar + } + } + fragment fragOnScalar on Int { + name + } + |] + expected = Error + { message = + "Fragment cannot condition on non composite type \ + \\"Int\"." + , locations = [AST.Location 7 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected + + it "rejects inline fragments on scalar types" $ + let queryString = [r| + { + ... on Boolean { + name + } + } + |] + expected = Error + { message = + "Fragment cannot condition on non composite type \ + \\"Boolean\"." + , locations = [AST.Location 3 17] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected