Validate directives are in valid locations

2020-10-02 06:31:38 +02:00 · 2020-10-02 06:31:38 +02:00 · 6daae8a521
commit 6daae8a521
parent 56b63f1c3e
7 changed files with 209 additions and 52 deletions
--- a/src/Language/GraphQL/AST/DirectiveLocation.hs
+++ b/src/Language/GraphQL/AST/DirectiveLocation.hs
@ -2,6 +2,8 @@
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

+{-# LANGUAGE Safe #-}
+
 -- | Various parts of a GraphQL document can be annotated with directives. 
 -- This module describes locations in a document where directives can appear.
 module Language.GraphQL.AST.DirectiveLocation
@ -16,7 +18,13 @@ module Language.GraphQL.AST.DirectiveLocation
 data DirectiveLocation
    = ExecutableDirectiveLocation ExecutableDirectiveLocation
    | TypeSystemDirectiveLocation TypeSystemDirectiveLocation
-    deriving (Eq, Show)
+    deriving Eq
+
+instance Show DirectiveLocation where
+    show (ExecutableDirectiveLocation directiveLocation) =
+        show directiveLocation
+    show (TypeSystemDirectiveLocation directiveLocation) =
+        show directiveLocation

 -- | Where directives can appear in an executable definition, like a query.
 data ExecutableDirectiveLocation
@ -27,7 +35,16 @@ data ExecutableDirectiveLocation
    | FragmentDefinition
    | FragmentSpread
    | InlineFragment
-    deriving (Eq, Show)
+    deriving Eq
+
+instance Show ExecutableDirectiveLocation where
+    show Query = "QUERY"
+    show Mutation = "MUTATION"
+    show Subscription = "SUBSCRIPTION"
+    show Field = "FIELD"
+    show FragmentDefinition = "FRAGMENT_DEFINITION"
+    show FragmentSpread = "FRAGMENT_SPREAD"
+    show InlineFragment = "INLINE_FRAGMENT"

 -- | Where directives can appear in a type system definition.
 data TypeSystemDirectiveLocation
@ -42,4 +59,17 @@ data TypeSystemDirectiveLocation
    | EnumValue
    | InputObject
    | InputFieldDefinition
-    deriving (Eq, Show)
+    deriving Eq
+
+instance Show TypeSystemDirectiveLocation where
+    show Schema = "SCHEMA"
+    show Scalar = "SCALAR"
+    show Object = "OBJECT"
+    show FieldDefinition = "FIELD_DEFINITION"
+    show ArgumentDefinition = "ARGUMENT_DEFINITION"
+    show Interface = "INTERFACE"
+    show Union = "UNION"
+    show Enum = "ENUM"
+    show EnumValue = "ENUM_VALUE"
+    show InputObject = "INPUT_OBJECT"
+    show InputFieldDefinition = "INPUT_FIELD_DEFINITION"
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@ -1,5 +1,6 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Safe #-}

 -- | This module defines an abstract syntax tree for the @GraphQL@ language. It
 -- follows closely the structure given in the specification. Please refer to
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@ -1,6 +1,7 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE Safe #-}

 -- | This module defines a minifier and a printer for the @GraphQL@ language.
 module Language.GraphQL.AST.Encoder
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@ -132,38 +132,104 @@ typeSystemExtension context rule = \case

 typeExtension :: forall m. Validation m -> ApplyRule m Full.TypeExtension
 typeExtension context rule = \case
-    Full.ScalarTypeExtension _ directives' -> directives context rule directives'
+    Full.ScalarTypeExtension _ directives' ->
+        directives context rule scalarLocation directives'
    Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields
-        -> directives context rule directives'
+        -> directives context rule objectLocation directives'
        >< foldMap (fieldDefinition context rule) fields
    Full.ObjectTypeDirectivesExtension _ _ directives' ->
-        directives context rule directives'
+        directives context rule objectLocation directives'
    Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty
    Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields
-        -> directives context rule directives'
+        -> directives context rule interfaceLocation directives'
        >< foldMap (fieldDefinition context rule) fields
    Full.InterfaceTypeDirectivesExtension _ directives' ->
-        directives context rule directives'
+        directives context rule interfaceLocation directives'
    Full.UnionTypeUnionMemberTypesExtension _ directives' _ ->
-        directives context rule directives'
+        directives context rule unionLocation directives'
    Full.UnionTypeDirectivesExtension _ directives' ->
-        directives context rule directives'
+        directives context rule unionLocation directives'
    Full.EnumTypeEnumValuesDefinitionExtension _ directives' values
-        -> directives context rule directives'
+        -> directives context rule enumLocation directives'
        >< foldMap (enumValueDefinition context rule) values
    Full.EnumTypeDirectivesExtension _ directives' ->
-        directives context rule directives'
+        directives context rule enumLocation directives'
    Full.InputObjectTypeInputFieldsDefinitionExtension _ directives' fields
-        -> directives context rule directives'
-        >< foldMap (inputValueDefinition context rule) fields
+        -> directives context rule inputObjectLocation directives'
+        >< foldMap forEachInputFieldDefinition fields
    Full.InputObjectTypeDirectivesExtension _ directives' ->
-        directives context rule directives'
+        directives context rule inputObjectLocation directives'
+  where
+    forEachInputFieldDefinition =
+        inputValueDefinition context rule inputFieldDefinitionLocation

 schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension
 schemaExtension context rule = \case
    Full.SchemaOperationExtension directives' _ ->
-        directives context rule directives'
-    Full.SchemaDirectivesExtension directives' -> directives context rule directives'
+        directives context rule schemaLocation directives'
+    Full.SchemaDirectivesExtension directives' ->
+        directives context rule schemaLocation directives'
+
+schemaLocation :: DirectiveLocation
+schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema
+
+interfaceLocation :: DirectiveLocation
+interfaceLocation = TypeSystemDirectiveLocation DirectiveLocation.Interface
+
+objectLocation :: DirectiveLocation
+objectLocation = TypeSystemDirectiveLocation DirectiveLocation.Object
+
+unionLocation :: DirectiveLocation
+unionLocation = TypeSystemDirectiveLocation DirectiveLocation.Union
+
+enumLocation :: DirectiveLocation
+enumLocation = TypeSystemDirectiveLocation DirectiveLocation.Enum
+
+inputObjectLocation :: DirectiveLocation
+inputObjectLocation = TypeSystemDirectiveLocation DirectiveLocation.InputObject
+
+scalarLocation :: DirectiveLocation
+scalarLocation = TypeSystemDirectiveLocation DirectiveLocation.Scalar
+
+enumValueLocation :: DirectiveLocation
+enumValueLocation = TypeSystemDirectiveLocation DirectiveLocation.EnumValue
+
+fieldDefinitionLocation :: DirectiveLocation
+fieldDefinitionLocation =
+    TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
+
+inputFieldDefinitionLocation :: DirectiveLocation
+inputFieldDefinitionLocation =
+    TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
+
+argumentDefinitionLocation :: DirectiveLocation
+argumentDefinitionLocation =
+    TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
+
+queryLocation :: DirectiveLocation
+queryLocation = ExecutableDirectiveLocation DirectiveLocation.Query
+
+mutationLocation :: DirectiveLocation
+mutationLocation = ExecutableDirectiveLocation DirectiveLocation.Mutation
+
+subscriptionLocation :: DirectiveLocation
+subscriptionLocation =
+    ExecutableDirectiveLocation DirectiveLocation.Subscription
+
+fieldLocation :: DirectiveLocation
+fieldLocation = ExecutableDirectiveLocation DirectiveLocation.Field
+
+fragmentDefinitionLocation :: DirectiveLocation
+fragmentDefinitionLocation =
+    ExecutableDirectiveLocation DirectiveLocation.FragmentDefinition
+
+fragmentSpreadLocation :: DirectiveLocation
+fragmentSpreadLocation =
+    ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
+
+inlineFragmentLocation :: DirectiveLocation
+inlineFragmentLocation =
+    ExecutableDirectiveLocation DirectiveLocation.InlineFragment

 executableDefinition :: forall m
    . Validation.Rule m
@ -179,7 +245,8 @@ typeSystemDefinition :: forall m
    . Validation m
    -> ApplyRule m Full.TypeSystemDefinition
 typeSystemDefinition context rule = \case
-    Full.SchemaDefinition directives' _ -> directives context rule directives'
+    Full.SchemaDefinition directives' _ ->
+        directives context rule schemaLocation directives'
    Full.TypeDefinition typeDefinition' ->
        typeDefinition context rule typeDefinition'
    Full.DirectiveDefinition _ _ arguments' _ ->
@ -188,44 +255,54 @@ typeSystemDefinition context rule = \case
 typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
 typeDefinition context rule = \case
    Full.ScalarTypeDefinition _ _ directives' ->
-        directives context rule directives'
+        directives context rule scalarLocation directives'
    Full.ObjectTypeDefinition _ _ _ directives' fields
-        -> directives context rule directives'
+        -> directives context rule objectLocation directives'
         >< foldMap (fieldDefinition context rule) fields
    Full.InterfaceTypeDefinition _ _ directives' fields
-        -> directives context rule directives'
+        -> directives context rule interfaceLocation directives'
        >< foldMap (fieldDefinition context rule) fields
    Full.UnionTypeDefinition _ _ directives' _ ->
-        directives context rule directives'
+        directives context rule unionLocation directives'
    Full.EnumTypeDefinition _ _ directives' values
-        -> directives context rule directives'
+        -> directives context rule enumLocation directives'
        >< foldMap (enumValueDefinition context rule) values
    Full.InputObjectTypeDefinition _ _ directives' fields
-        -> directives context rule directives'
-        <> foldMap (inputValueDefinition context rule) fields
+        -> directives context rule inputObjectLocation directives'
+        <> foldMap forEachInputFieldDefinition fields
+  where
+    forEachInputFieldDefinition =
+        inputValueDefinition context rule inputFieldDefinitionLocation

 enumValueDefinition :: forall m
    . Validation m
    -> ApplyRule m Full.EnumValueDefinition
 enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') =
-    directives context rule directives'
+    directives context rule enumValueLocation directives'

 fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition
 fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives')
-    = directives context rule directives'
+    = directives context rule fieldDefinitionLocation directives'
    >< argumentsDefinition context rule arguments'

 argumentsDefinition :: forall m
    . Validation m
    -> ApplyRule m Full.ArgumentsDefinition
 argumentsDefinition context rule (Full.ArgumentsDefinition definitions) =
-    foldMap (inputValueDefinition context rule) definitions
+    foldMap forEachArgument definitions
+  where
+    forEachArgument =
+        inputValueDefinition context rule argumentDefinitionLocation

 inputValueDefinition :: forall m
    . Validation m
-    -> ApplyRule m Full.InputValueDefinition
-inputValueDefinition context rule (Full.InputValueDefinition _ _ _ _ directives') =
-    directives context rule directives'
+    -> Validation.Rule m
+    -> DirectiveLocation
+    -> Full.InputValueDefinition
+    -> Seq (Validation.RuleT m)
+inputValueDefinition context rule directiveLocation definition' =
+    let Full.InputValueDefinition _ _ _ _ directives' = definition'
+     in directives context rule directiveLocation directives'

 operationDefinition :: forall m
    . Validation.Rule m
@ -239,18 +316,22 @@ operationDefinition rule context operation
    , Full.OperationDefinition _ _ variables _ _ _ <- operation =
        foldMap (variableDefinition context rule) variables |> variablesRule variables
    | Full.SelectionSet selections _ <- operation =
-        selectionSet context types' rule (getRootType Full.Query) selections
-    | Full.OperationDefinition operationType _ _ directives' selections _  <- operation
-        = selectionSet context types' rule (getRootType operationType) selections
-        >< directives context rule directives'
+        selectionSet context types' rule queryRoot selections
+    | Full.OperationDefinition Full.Query _ _ directives' selections _  <- operation
+        = selectionSet context types' rule queryRoot selections
+        >< directives context rule queryLocation directives'
+    | Full.OperationDefinition Full.Mutation _ _ directives' selections _  <- operation =
+        let root = Out.NamedObjectType <$> Schema.mutation schema'
+         in selectionSet context types' rule root selections
+        >< directives context rule mutationLocation directives'
+    | Full.OperationDefinition Full.Subscription _ _ directives' selections _  <- operation =
+        let root = Out.NamedObjectType <$> Schema.subscription schema'
+         in selectionSet context types' rule root selections
+        >< directives context rule subscriptionLocation directives'
  where
+    schema' = Validation.schema context
+    queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
    types' = Validation.types context
-    getRootType Full.Query =
-       Just $ Out.NamedObjectType $ Schema.query $ Validation.schema context
-    getRootType Full.Mutation =
-       Out.NamedObjectType <$> Schema.mutation (Validation.schema context)
-    getRootType Full.Subscription =
-        Out.NamedObjectType <$> Schema.subscription (Validation.schema context)
        
 typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
 typeToOut (Schema.ObjectType objectType) =
@ -320,7 +401,7 @@ fragmentDefinition rule context definition'
    types' = Validation.types context
    applyToChildren typeCondition directives' selections
        = selectionSet context types' rule (lookupType' typeCondition) selections
-        >< directives context rule directives'
+        >< directives context rule fragmentDefinitionLocation directives'
    lookupType' = flip lookupType types'

 lookupType :: forall m
@ -367,7 +448,7 @@ field context types' rule objectType field' = go field'
            typeField = objectType >>= lookupTypeField fieldName
            argumentTypes = maybe mempty typeFieldArguments typeField
         in selectionSet context types' rule (typeFieldType <$> typeField) selections
-            >< directives context rule directives'
+            >< directives context rule fieldLocation directives'
            >< arguments rule argumentTypes arguments'

 arguments :: forall m
@ -424,7 +505,7 @@ inlineFragment context types' rule objectType inlineFragment' =
    refineTarget Nothing = objectType
    applyToChildren objectType' directives' selections
        = selectionSet context types' rule objectType' selections
-        >< directives context rule directives'
+        >< directives context rule inlineFragmentLocation directives'

 fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread
 fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _)
@ -432,15 +513,18 @@ fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _
        applyToChildren |> fragmentRule fragmentSpread'
    | otherwise = applyToChildren
  where
-    applyToChildren = directives context rule directives'
+    applyToChildren = directives context rule fragmentSpreadLocation directives'

 directives :: Traversable t
    => forall m
    . Validation m
-    -> ApplyRule m (t Full.Directive)
-directives context rule directives'
+    -> Validation.Rule m
+    -> DirectiveLocation
+    -> t Full.Directive
+    -> Seq (Validation.RuleT m)
+directives context rule directiveLocation directives'
    | Validation.DirectivesRule directivesRule <- rule =
-        applyToChildren |> directivesRule directiveList
+        applyToChildren |> directivesRule directiveLocation directiveList
    | otherwise = applyToChildren
  where
    directiveList = toList directives'
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@ -10,7 +10,8 @@

 -- | This module contains default rules defined in the GraphQL specification.
 module Language.GraphQL.Validate.Rules
-    ( executableDefinitionsRule
+    ( directivesInValidLocationsRule
+    , executableDefinitionsRule
    , fieldsOnCorrectTypeRule
    , fragmentsOnCompositeTypesRule
    , fragmentSpreadTargetDefinedRule
@ -90,6 +91,7 @@ specifiedRules =
    , uniqueInputFieldNamesRule
    -- Directives.
    , knownDirectiveNamesRule
+    , directivesInValidLocationsRule
    , uniqueDirectiveNamesRule
    -- Variables.
    , uniqueVariableNamesRule
@ -514,7 +516,7 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
 -- of each directive is allowed per location.
 uniqueDirectiveNamesRule :: forall m. Rule m
 uniqueDirectiveNamesRule = DirectivesRule
-    $ lift . filterDuplicates extract "directive"
+    $ const $ lift . filterDuplicates extract "directive"
  where
    extract (Directive directiveName _ location') = (directiveName, location')

@ -818,7 +820,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
 -- | GraphQL servers define what directives they support. For each usage of a
 -- directive, the directive must be available on that server.
 knownDirectiveNamesRule :: Rule m
-knownDirectiveNamesRule = DirectivesRule $ \directives' -> do
+knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
    definitions' <- asks directives
    let directiveSet = HashSet.fromList $ fmap directiveName directives'
    let definitionSet = HashSet.fromList $ HashMap.keys definitions'
@ -867,3 +869,27 @@ knownInputFieldNamesRule = ValueRule go constGo
        , Text.unpack typeName
        , "\"."
        ]
+
+-- | GraphQL servers define what directives they support and where they support
+-- them. For each usage of a directive, the directive must be used in a location
+-- that the server has declared support for.
+directivesInValidLocationsRule :: Rule m
+directivesInValidLocationsRule = DirectivesRule directivesRule
+  where
+    directivesRule directiveLocation directives' = do
+        Directive directiveName _ location <- lift $ Seq.fromList directives'
+        maybeDefinition <- asks $ HashMap.lookup directiveName . directives
+        case maybeDefinition of
+            Just (Schema.Directive _ allowedLocations _)
+                | directiveLocation `notElem` allowedLocations -> pure $ Error
+                    { message = errorMessage directiveName directiveLocation
+                    , locations = [location]
+                    }
+            _ -> lift mempty
+    errorMessage directiveName directiveLocation = concat
+        [ "Directive \"@"
+        , Text.unpack directiveName
+        , "\" may not be used on "
+        , show directiveLocation
+        , "."
+        ]
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/src/Language/GraphQL/Validate/Validation.hs
@ -13,6 +13,7 @@ module Language.GraphQL.Validate.Validation
 import Control.Monad.Trans.Reader (ReaderT)
 import Data.HashMap.Strict (HashMap)
 import Data.Sequence (Seq)
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
 import Language.GraphQL.AST.Document
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
@ -45,7 +46,7 @@ data Rule m
    | FragmentSpreadRule (FragmentSpread -> RuleT m)
    | FieldRule (Maybe (Out.Type m) -> Field -> RuleT m)
    | ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m)
-    | DirectivesRule ([Directive] -> RuleT m)
+    | DirectivesRule (DirectiveLocation -> [Directive] -> RuleT m)
    | VariablesRule ([VariableDefinition] -> RuleT m)
    | ValueRule (Maybe In.Type -> Value -> RuleT m) (Maybe In.Type -> ConstValue -> RuleT m)

--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@ -606,3 +606,17 @@ spec =
                    , locations = [AST.Location 3 36]
                    }
             in validate queryString `shouldBe` [expected]
+
+        it "rejects directives in invalid locations" $
+            let queryString = [r|
+              query @skip(if: $foo) {
+                dog {
+                  name
+                }
+              }
+            |]
+                expected = Error
+                    { message = "Directive \"@skip\" may not be used on QUERY."
+                    , locations = [AST.Location 2 21]
+                    }
+             in validate queryString `shouldBe` [expected]