Validate the subscription root

…not to be an introspection field.

src/Language/GraphQL/Validate/Rules.hs

@@ -137,25 +137,28 @@ singleFieldSubscriptionsRule :: forall m. Rule m
 singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
     Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
         groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
-        case HashSet.size groupedFieldSet of
-            1 -> lift mempty
-            _
-                | Just name <- name' -> pure $ Error
+        case HashSet.toList groupedFieldSet of
+            [rootName]
+                | Text.isPrefixOf "__" rootName -> makeError location' name'
+                    "exactly one top level field, which must not be an introspection field."
+                | otherwise -> lift mempty
+            [] -> makeError location' name' "exactly one top level field."
+            _ -> makeError location' name' "only one top level field."
+    _ -> lift mempty
+  where
+    makeError location' (Just operationName) errorLine = pure $ Error
         { message = concat
             [ "Subscription \""
-                        , Text.unpack name
-                        , "\" must select only one top level field."
+            , Text.unpack operationName
+            , "\" must select "
+            , errorLine
             ]
         , locations = [location']
         }
-                | otherwise -> pure $ Error
-                    { message = errorMessage
+    makeError location' Nothing errorLine = pure $ Error
+        { message = "Anonymous Subscription must select " <> errorLine
         , locations = [location']
         }
-    _ -> lift mempty
-  where
-    errorMessage =
-        "Anonymous Subscription must select only one top level field."
     collectFields = foldM forEach HashSet.empty
     forEach accumulator = \case
         Full.FieldSelection fieldSelection -> forField accumulator fieldSelection

tests/Language/GraphQL/Validate/RulesSpec.hs

@@ -18,7 +18,7 @@ import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Validate
-import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain, xit)
+import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain)
 import Text.Megaparsec (parse, errorBundlePretty)
 
 petSchema :: Schema IO
@@ -206,14 +206,14 @@ spec =
                         }
                  in validate queryString `shouldContain` [expected]
 
-            xit "rejects an introspection field as the subscription root" $
+            it "rejects an introspection field as the subscription root" $
                 let queryString = "subscription sub {\n\
                         \  __typename\n\
                         \}"
                     expected = Error
                         { message =
-                            "Subscription \"sub\" must select only one top \
-                            \level field."
+                            "Subscription \"sub\" must select exactly one top \
+                            \level field, which must not be an introspection field."
                         , locations = [AST.Location 1 1]
                         }
                  in validate queryString `shouldContain` [expected]