diff options
| -rw-r--r-- | README.md | 2 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Document.hs | 6 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 42 | ||||
| -rw-r--r-- | stack.yaml | 2 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ValidateSpec.hs | 24 |
5 files changed, 64 insertions, 12 deletions
@@ -1,4 +1,4 @@ -# GraphQL implementation in Haskell. +# GraphQL implementation in Haskell [](https://hackage.haskell.org/package/graphql) [](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index f60ddda..72d39bb 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -62,6 +62,12 @@ data Location = Location , column :: Word } deriving (Eq, Show) +instance Ord Location where + compare (Location thisLine thisColumn) (Location thatLine thatColumn) + | thisLine < thatLine = LT + | thisLine > thatLine = GT + | otherwise = compare thisColumn thatColumn + -- ** Document -- | GraphQL document. diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index a3b1a59..466dcae 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | This module contains default rules defined in the GraphQL specification. @@ -27,22 +28,19 @@ specifiedRules :: forall m. [Rule m] specifiedRules = [ executableDefinitionsRule , singleFieldSubscriptionsRule + , loneAnonymousOperationRule ] -- | Definition must be OperationDefinition or FragmentDefinition. executableDefinitionsRule :: forall m. Rule m -executableDefinitionsRule = DefinitionRule go - where - go :: Definition -> RuleT m - go (ExecutableDefinition _) = lift Nothing - go _ = pure - "Definition must be OperationDefinition or FragmentDefinition." +executableDefinitionsRule = DefinitionRule $ \case + ExecutableDefinition _ -> lift Nothing + _ -> pure "Definition must be OperationDefinition or FragmentDefinition." -- | Subscription operations must have exactly one root field. singleFieldSubscriptionsRule :: forall m. Rule m -singleFieldSubscriptionsRule = OperationDefinitionRule go - where - go (OperationDefinition Subscription name' _ _ rootFields _) = do +singleFieldSubscriptionsRule = OperationDefinitionRule $ \case + OperationDefinition Subscription name' _ _ rootFields _ -> do groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty case HashSet.size groupedFieldSet of 1 -> lift Nothing @@ -54,7 +52,8 @@ singleFieldSubscriptionsRule = OperationDefinitionRule go ] | otherwise -> pure "Anonymous Subscription must select only one top level field." - go _ = lift Nothing + _ -> lift Nothing + where collectFields selectionSet = foldM forEach HashSet.empty selectionSet forEach accumulator (Field alias name _ directives _) | any skip directives = pure accumulator @@ -98,3 +97,26 @@ singleFieldSubscriptionsRule = OperationDefinitionRule go Nothing -> pure accumulator Just (FragmentDefinition _ typeCondition _ selectionSet _) -> collectFromFragment typeCondition selectionSet accumulator + +-- | GraphQL allows a shortâhand form for defining query operations when only +-- that one operation exists in the document. +loneAnonymousOperationRule :: forall m. Rule m +loneAnonymousOperationRule = OperationDefinitionRule $ \case + SelectionSet _ thisLocation -> check thisLocation + OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation + _ -> lift Nothing + where + check thisLocation = asks ast + >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing + filterAnonymousOperations thisLocation definition Nothing + | ExecutableDefinition executableDefinition <- definition + , DefinitionOperation operationDefinition <- executableDefinition = + compareAnonymousOperations thisLocation operationDefinition + filterAnonymousOperations _ _ accumulator = accumulator + compareAnonymousOperations thisLocation operationDefinition + | OperationDefinition _ _ _ _ _ thatLocation <- operationDefinition + , thisLocation /= thatLocation = pure message + | SelectionSet _ thatLocation <- operationDefinition + , thisLocation /= thatLocation = pure message + compareAnonymousOperations _ _ = Nothing + message = "This anonymous operation must be the only defined operation." @@ -1,4 +1,4 @@ -resolver: lts-16.10 +resolver: lts-16.11 packages: - . diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index c463dd9..4b5e638 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -209,3 +209,27 @@ spec = , path = [] } in validate queryString `shouldBe` Seq.singleton expected + + it "rejects multiple anonymous operations" $ + let queryString = [r| + { + dog { + name + } + } + + query getName { + dog { + owner { + name + } + } + } + |] + expected = Error + { message = + "This anonymous operation must be the only defined operation." + , locations = [AST.Location 2 15] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected |