Validate directives are defined

6 files changed, 103 insertions, 11 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index b0f4606..782fa70 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -51,6 +51,7 @@ and this project adheres to
   - `fieldsOnCorrectTypeRule`
   - `scalarLeafsRule`
   - `knownArgumentNamesRule`
+  - `knownDirectiveNamesRule`
 - `AST.Document.Field`.
 - `AST.Document.FragmentSpread`.
 - `AST.Document.InlineFragment`.
diff --git a/README.md b/README.md
index 455ab50..32c55ce 100644
--- a/README.md
+++ b/README.md
@@ -65,7 +65,6 @@ To be able to work with this schema, we are going to implement it in Haskell.
 ```haskell
 {-# LANGUAGE OverloadedStrings #-}
 
-import Control.Exception (SomeException)
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8
 import qualified Data.HashMap.Strict as HashMap
@@ -75,9 +74,8 @@ import qualified Language.GraphQL.Type.Out as Out
 
 -- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions.
 -- Our first schema supports only queries.
-schema :: Schema IO
-schema = Schema
-    { query = queryType, mutation = Nothing, subscription = Nothing }
+citeSchema :: Schema IO
+citeSchema = schema queryType
 
 -- GraphQL distinguishes between input and output types. Input types are field
 -- argument types and they are defined in Language.GraphQL.Type.In. Output types
@@ -99,6 +97,7 @@ queryType = Out.ObjectType "Query" (Just "Root Query type.") []
     -- Our resolver just returns a constant value.
     citeResolver = ValueResolver citeField
         $ pure "Piscis primum a capite foetat"
+
     -- The first argument is an optional field description. The second one is
     -- the field type and the third one is for arguments (we have none in this
     -- example).
@@ -116,7 +115,7 @@ queryType = Out.ObjectType "Query" (Just "Root Query type.") []
 -- mutations.
 main :: IO ()
 main = do
-    Right result <- graphql schema "{ cite }"
+    Right result <- graphql citeSchema "{ cite }"
     ByteString.Lazy.Char8.putStrLn $ Aeson.encode result
 ```
 
diff --git a/docs/tutorial/test.hs b/docs/tutorial/test.hs
new file mode 100644
index 0000000..631407c
--- /dev/null
+++ b/docs/tutorial/test.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL
+import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.Out as Out
+
+-- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions.
+-- Our first schema supports only queries.
+citeSchema :: Schema IO
+citeSchema = schema queryType
+
+-- GraphQL distinguishes between input and output types. Input types are field
+-- argument types and they are defined in Language.GraphQL.Type.In. Output types
+-- are result types, they are defined in Language.GraphQL.Type.Out. Root types
+-- are always object types.
+--
+-- Here we define a type "Query". The second argument is an optional
+-- description, the third one is the list of interfaces implemented by the
+-- object type. The last argument is a field map. Keys are field names, values
+-- are field definitions and resolvers. Resolvers are the functions, where the
+-- actual logic lives, they return values for the respective fields.
+queryType :: Out.ObjectType IO
+queryType = Out.ObjectType "Query" (Just "Root Query type.") []
+    $ HashMap.singleton "cite" citeResolver
+  where
+    -- 'ValueResolver' is a 'Resolver' data constructor, it combines a field
+    -- definition with its resolver function. This function resolves a value for
+    -- a field (as opposed to the 'EventStreamResolver' used by subscriptions).
+    -- Our resolver just returns a constant value.
+    citeResolver = ValueResolver citeField
+        $ pure "Piscis primum a capite foetat"
+
+    -- The first argument is an optional field description. The second one is
+    -- the field type and the third one is for arguments (we have none in this
+    -- example).
+    --
+    -- GraphQL has named and wrapping types. String is a scalar, named type.
+    -- Named types are nullable by default. To make our "cite" field
+    -- non-nullable, we wrap it in the wrapping type, Non-Null.
+    citeField = Out.Field
+        (Just "Provides a cite.") (Out.NonNullScalarType string) HashMap.empty
+
+-- Now we can execute a query. Since our schema defines only one field,
+-- everything we can do is to ask to resolve it and give back the result.
+-- Since subscriptions don't return plain values, the 'graphql' function returns
+-- an 'Either'. 'Left' is for subscriptions, 'Right' is for queries and
+-- mutations.
+main :: IO ()
+main = do
+    Right result <- graphql citeSchema "{ cite }"
+    ByteString.Lazy.Char8.putStrLn $ Aeson.encode result
+
diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs
index dc44c1e..6a68e35 100644
--- a/docs/tutorial/tutorial.lhs
+++ b/docs/tutorial/tutorial.lhs
@@ -39,8 +39,7 @@ Now, as our first example, we are going to look at the example from
 First we build a GraphQL schema.
 
 > schema1 :: Schema IO
-> schema1 = Schema
->   { query = queryType , mutation = Nothing , subscription = Nothing }
+> schema1 = schema queryType
 >
 > queryType :: ObjectType IO
 > queryType = ObjectType "Query" Nothing []
@@ -77,8 +76,7 @@ This runs the query by fetching the one field defined, returning
 For this example, we're going to be using time.
 
 > schema2 :: Schema IO
-> schema2 = Schema
->   { query = queryType2, mutation = Nothing, subscription = Nothing }
+> schema2 = schema queryType2
 >
 > queryType2 :: ObjectType IO
 > queryType2 = ObjectType "Query" Nothing []
@@ -115,8 +113,7 @@ This runs the query, returning the current time
 Now that we have two resolvers, we can define a schema which uses them both.
 
 > schema3 :: Schema IO
-> schema3 = Schema
->   { query = queryType3, mutation = Nothing, subscription = Nothing }
+> schema3 = schema queryType3
 >
 > queryType3 :: ObjectType IO
 > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index bd0b4ed..6e550f8 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -16,6 +16,7 @@ module Language.GraphQL.Validate.Rules
     , fragmentSpreadTypeExistenceRule
     , loneAnonymousOperationRule
     , knownArgumentNamesRule
+    , knownDirectiveNamesRule
     , noFragmentCyclesRule
     , noUndefinedVariablesRule
     , noUnusedFragmentsRule
@@ -84,6 +85,7 @@ specifiedRules =
     -- Values
     , uniqueInputFieldNamesRule
     -- Directives.
+    , knownDirectiveNamesRule
     , uniqueDirectiveNamesRule
     -- Variables.
     , uniqueVariableNamesRule
@@ -812,3 +814,27 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
         , Text.unpack directiveName
         , "\"."
         ]
+
+-- | 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
+    definitions' <- asks directives
+    let directiveSet = HashSet.fromList $ fmap directiveName directives'
+    let definitionSet = HashSet.fromList $ HashMap.keys definitions'
+    let difference = HashSet.difference directiveSet definitionSet
+    let undefined' = filter (definitionFilter difference) directives'
+    lift $ Seq.fromList $ makeError <$> undefined'
+  where
+    definitionFilter difference = flip HashSet.member difference
+        . directiveName
+    directiveName (Directive directiveName' _ _) = directiveName'
+    makeError (Directive directiveName' _ location) = Error
+        { message = errorMessage directiveName'
+        , locations = [location]
+        }
+    errorMessage directiveName' = concat
+        [ "Unknown directive \"@"
+        , Text.unpack directiveName'
+        , "\"."
+        ]
diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
index 84bdfba..fd53145 100644
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -576,3 +576,17 @@ spec =
                     , locations = [AST.Location 4 63]
                     }
              in validate queryString `shouldBe` [expected]
+
+        it "rejects undefined directives" $
+            let queryString = [r|
+              {
+                dog {
+                  isHousetrained(atOtherHomes: true) @ignore(if: true)
+                }
+              }
+            |]
+                expected = Error
+                    { message = "Unknown directive \"@ignore\"."
+                    , locations = [AST.Location 4 54]
+                    }
+             in validate queryString `shouldBe` [expected]