diff --git a/docs/source/tutorial/tutorial.cabal b/docs/source/tutorial/tutorial.cabal index 6f3ded8..83e21bf 100644 --- a/docs/source/tutorial/tutorial.cabal +++ b/docs/source/tutorial/tutorial.cabal @@ -1,6 +1,8 @@ --- This file has been generated from package.yaml by hpack version 0.15.0. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: b3da6c729f0fa19c9ad82cb7e45f616850463bcc1654b9cd4797e34f6685ebd8 name: tutorial version: 0.0.1 @@ -18,11 +20,11 @@ library other-modules: Paths_tutorial build-depends: - base >= 4.9 && < 5 - , protolude + aeson + , base >=4.9 && <5 , graphql-api + , markdown-unlit >=0.4 + , protolude , random - , markdown-unlit >= 0.4 - , aeson default-language: Haskell2010 ghc-options: -Wall -pgmL markdown-unlit diff --git a/graphql-wai/graphql-wai.cabal b/graphql-wai/graphql-wai.cabal index 16b423a..10caf71 100644 --- a/graphql-wai/graphql-wai.cabal +++ b/graphql-wai/graphql-wai.cabal @@ -1,6 +1,8 @@ --- This file has been generated from package.yaml by hpack version 0.15.0. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: 12d030d800c1c036c89a9464dd8de8b05f9f6dc28e0faae9d2b105b2b120460e name: graphql-wai version: 0.1.0 @@ -22,15 +24,17 @@ library default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints -Werror build-depends: - base >= 4.9 && < 5 - , protolude + aeson + , base >=4.9 && <5 , exceptions - , wai - , http-types , graphql-api - , aeson + , http-types + , protolude + , wai exposed-modules: GraphQL.Wai + other-modules: + Paths_graphql_wai default-language: Haskell2010 test-suite wai-tests @@ -41,13 +45,15 @@ test-suite wai-tests default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints -Werror build-depends: - base >= 4.9 && < 5 - , protolude + aeson + , base >=4.9 && <5 , exceptions - , wai - , http-types , graphql-api - , aeson - , wai-extra , graphql-wai + , http-types + , protolude + , wai + , wai-extra + other-modules: + Paths_graphql_wai default-language: Haskell2010 diff --git a/src/GraphQL/Internal/Execution.hs b/src/GraphQL/Internal/Execution.hs index f793fae..2203917 100644 --- a/src/GraphQL/Internal/Execution.hs +++ b/src/GraphQL/Internal/Execution.hs @@ -51,7 +51,7 @@ import GraphQL.Internal.Validation -- * Return {operation}. getOperation :: QueryDocument value -> Maybe Name -> Either ExecutionError (Operation value) getOperation (LoneAnonymousOperation op) Nothing = pure op -getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup name ops) +getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup (pure name) ops) getOperation (MultipleOperations ops) Nothing = case toList ops of [op] -> pure op diff --git a/src/GraphQL/Internal/Name.hs b/src/GraphQL/Internal/Name.hs index 90c8772..ea2b0c1 100644 --- a/src/GraphQL/Internal/Name.hs +++ b/src/GraphQL/Internal/Name.hs @@ -35,6 +35,7 @@ import GraphQL.Internal.Syntax.Tokens (tok) -- https://facebook.github.io/graphql/#sec-Names newtype Name = Name { unName :: T.Text } deriving (Eq, Ord, Show) + -- | Create a 'Name', panicking if the given text is invalid. -- -- Prefer 'makeName' to this in all cases. diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs index 82f68e3..71c15b2 100644 --- a/src/GraphQL/Internal/Syntax/AST.hs +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -49,10 +49,10 @@ module GraphQL.Internal.Syntax.AST import Protolude --import Data.String (IsString(..)) -import Test.QuickCheck (Arbitrary(..), elements, listOf, oneof) +import Test.QuickCheck (Arbitrary(..), listOf, oneof) import GraphQL.Internal.Arbitrary (arbitraryText) -import GraphQL.Internal.Name (HasName(getName), Name(unName, Name), unsafeMakeName) +import GraphQL.Internal.Name (Name) -- * Documents @@ -76,11 +76,12 @@ data OperationDefinition | AnonymousQuery SelectionSet deriving (Eq,Show) -data Node = Node Name [VariableDefinition] [Directive] SelectionSet +data Node = Node (Maybe Name) [VariableDefinition] [Directive] SelectionSet deriving (Eq,Show) -instance HasName Node where - getName (Node name _ _ _) = name +-- +getNodeName :: Node -> Maybe Name +getNodeName (Node maybeName _ _ _) = maybeName data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) deriving (Eq,Show) diff --git a/src/GraphQL/Internal/Syntax/Encoder.hs b/src/GraphQL/Internal/Syntax/Encoder.hs index 6891790..18fda0f 100644 --- a/src/GraphQL/Internal/Syntax/Encoder.hs +++ b/src/GraphQL/Internal/Syntax/Encoder.hs @@ -30,11 +30,15 @@ operationDefinition (AST.Mutation n) = "mutation " <> node n operationDefinition (AST.AnonymousQuery ss) = selectionSet ss node :: AST.Node -> Text -node (AST.Node name vds ds ss) = +node (AST.Node (Just name) vds ds ss) = unName name <> optempty variableDefinitions vds <> optempty directives ds <> selectionSet ss +node (AST.Node Nothing vds ds ss) = + optempty variableDefinitions vds + <> optempty directives ds + <> selectionSet ss variableDefinitions :: [AST.VariableDefinition] -> Text variableDefinitions = parensCommas variableDefinition diff --git a/src/GraphQL/Internal/Syntax/Parser.hs b/src/GraphQL/Internal/Syntax/Parser.hs index e6ca994..1c3d6d0 100644 --- a/src/GraphQL/Internal/Syntax/Parser.hs +++ b/src/GraphQL/Internal/Syntax/Parser.hs @@ -52,7 +52,7 @@ operationDefinition = "operationDefinition error!" node :: Parser AST.Node -node = AST.Node <$> nameParser +node = AST.Node <$> optional nameParser <*> optempty variableDefinitions <*> optempty directives <*> selectionSet diff --git a/src/GraphQL/Internal/Validation.hs b/src/GraphQL/Internal/Validation.hs index e7e0372..1c4d7f7 100644 --- a/src/GraphQL/Internal/Validation.hs +++ b/src/GraphQL/Internal/Validation.hs @@ -123,7 +123,7 @@ getSelectionSet (Mutation _ _ ss) = ss -- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'. type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value -type Operations value = Map Name (Operation value) +type Operations value = Map (Maybe Name) (Operation value) -- | Turn a parsed document into a known valid one. -- @@ -132,9 +132,9 @@ type Operations value = Map Name (Operation value) validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue) validate schema (AST.QueryDocument defns) = runValidator $ do let (operations, fragments) = splitBy splitDefns defns - let (anonymous, named) = splitBy splitOps operations + let (anonymous, maybeNamed) = splitBy splitOps operations (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments - case (anonymous, named) of + case (anonymous, maybeNamed) of ([], ops) -> do (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty assertAllFragmentsUsed frags (visitedFrags <> usedFrags) @@ -146,7 +146,7 @@ validate schema (AST.QueryDocument defns) = runValidator $ do validValuesSS <- validateValues ss resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS)) - _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst named)) + _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed)) where splitBy :: (a -> Either b c) -> [a] -> ([b], [c]) @@ -156,17 +156,17 @@ validate schema (AST.QueryDocument defns) = runValidator $ do splitDefns (AST.DefinitionFragment frag) = Right frag splitOps (AST.AnonymousQuery ss) = Left ss - splitOps (AST.Query node@(AST.Node name _ _ _)) = Right (name, (Query, node)) - splitOps (AST.Mutation node@(AST.Node name _ _ _)) = Right (name, (Mutation, node)) + splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node)) + splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node)) - assertAllFragmentsUsed :: Fragments value -> Set Name -> Validation () + assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation () assertAllFragmentsUsed fragments used = - let unused = Map.keysSet fragments `Set.difference` used + let unused = ( Set.map pure (Map.keysSet fragments)) `Set.difference` used in unless (Set.null unused) (throwE (UnusedFragments unused)) -- * Operations -validateOperations :: Schema -> Fragments AST.Value -> [(Name, (OperationType AST.Value, AST.Node))] -> StateT (Set Name) Validation (Operations AST.Value) +validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value) validateOperations schema fragments ops = do deduped <- lift (mapErrors DuplicateOperation (makeMap ops)) traverse validateNode deduped @@ -219,7 +219,7 @@ validateOperation (Mutation vars directives selectionSet) = do -- We do this /before/ validating the values (since that's much easier once -- everything is in a nice structure and away from the AST), which means we -- can't yet evaluate directives. -validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set Name) Validation (SelectionSetByType AST.Value) +validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set (Maybe Name)) Validation (SelectionSetByType AST.Value) validateSelectionSet schema fragments selections = do unresolved <- lift $ traverse (validateSelection schema) selections resolved <- traverse (resolveSelection fragments) unresolved @@ -508,14 +508,14 @@ validateSelection schema selection = -- We're doing a standard depth-first traversal of fragment references, where -- references are by name, so the set of names can be thought of as a record -- of visited references. -resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set Name) Validation (Selection' FragmentSpread a) +resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set (Maybe Name)) Validation (Selection' FragmentSpread a) resolveSelection fragments = traverseFragmentSpreads resolveFragmentSpread where resolveFragmentSpread (UnresolvedFragmentSpread name directive) = do case Map.lookup name fragments of Nothing -> lift (throwE (NoSuchFragment name)) Just fragment -> do - modify (Set.insert name) + modify (Set.insert (pure name)) pure (FragmentSpread name directive fragment) -- * Fragment definitions @@ -577,7 +577,7 @@ validateTypeCondition schema (NamedType typeCond) = -- -- -- -resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set Name) +resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set (Maybe Name)) resolveFragmentDefinitions allFragments = splitResult <$> traverse resolveFragment allFragments where @@ -595,12 +595,12 @@ resolveFragmentDefinitions allFragments = FragmentDefinition name cond directives <$> traverse (traverseFragmentSpreads resolveSpread) ss resolveSpread (UnresolvedFragmentSpread name directives) = do - visited <- Set.member name <$> get + visited <- Set.member (pure name) <$> get when visited (lift (throwE (CircularFragmentSpread name))) case Map.lookup name allFragments of Nothing -> lift (throwE (NoSuchFragment name)) Just definition -> do - modify (Set.insert name) + modify (Set.insert (pure name)) FragmentSpread name directives <$> resolveFragment' definition -- * Arguments @@ -727,12 +727,12 @@ data ValidationError -- with the given name. -- -- - = DuplicateOperation Name + = DuplicateOperation (Maybe Name) -- | 'MixedAnonymousOperations' means there was more than one operation -- defined in a document with an anonymous operation. -- -- - | MixedAnonymousOperations Int [Name] + | MixedAnonymousOperations Int [Maybe Name] -- | 'DuplicateArgument' means that multiple copies of the same argument was -- given to the same field, directive, etc. | DuplicateArgument Name @@ -755,7 +755,7 @@ data ValidationError | CircularFragmentSpread Name -- | 'UnusedFragments' means that fragments were defined that weren't used. -- - | UnusedFragments (Set Name) + | UnusedFragments (Set (Maybe Name)) -- | Variables were defined without being used. -- | UnusedVariables (Set Variable) @@ -777,10 +777,10 @@ data ValidationError deriving (Eq, Show) instance GraphQLError ValidationError where - formatError (DuplicateOperation name) = "More than one operation named '" <> show name <> "'" - formatError (MixedAnonymousOperations n names) - | n > 1 && null names = "Multiple anonymous operations defined. Found " <> show n - | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show names <> ")" + formatError (DuplicateOperation maybeName) = "More than one operation named '" <> show maybeName <> "'" + formatError (MixedAnonymousOperations n maybeNames) + | n > 1 && null maybeNames = "Multiple anonymous operations defined. Found " <> show n + | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show maybeNames <> ")" formatError (DuplicateArgument name) = "More than one argument named '" <> show name <> "'" formatError (DuplicateFragmentDefinition name) = "More than one fragment named '" <> show name <> "'" formatError (NoSuchFragment name) = "No fragment named '" <> show name <> "'" diff --git a/tests/ASTTests.hs b/tests/ASTTests.hs index 0a47e6a..ab8019b 100644 --- a/tests/ASTTests.hs +++ b/tests/ASTTests.hs @@ -78,7 +78,7 @@ tests = testSpec "AST" $ do output `shouldBe` "[1.5,1.5]" parseOnly Parser.value output `shouldBe` Right input describe "Parser" $ do - it "parses anonymous query documents" $ do + it "parses shorthand syntax documents" $ do let query = [r|{ dog { name @@ -96,6 +96,25 @@ tests = testSpec "AST" $ do ] parsed `shouldBe` expected + it "parses anonymous query documents" $ do + let query = [r|query { + dog { + name + } + }|] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing [] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ])) + ] + parsed `shouldBe` expected + it "parses invalid documents" $ do let query = [r|{ dog { @@ -121,7 +140,7 @@ tests = testSpec "AST" $ do ]) , AST.DefinitionOperation (AST.Query - (AST.Node "getName" [] [] + (AST.Node (pure "getName") [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField @@ -145,7 +164,37 @@ tests = testSpec "AST" $ do let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.Query - (AST.Node "houseTrainedQuery" + (AST.Node (pure "houseTrainedQuery") + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "Boolean")) + (Just (AST.ValueBoolean True)) + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) + ] [] []) + ]) + ])) + ] + parsed `shouldBe` expected + + it "parses anonymous query with variables" $ do + let query = [r| + query ($atOtherHomes: Boolean = true) { + dog { + isHousetrained(atOtherHomes: $atOtherHomes) + } + } + |] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeNamed (AST.NamedType "Boolean")) diff --git a/tests/ValidationTests.hs b/tests/ValidationTests.hs index 6b1f24c..420c576 100644 --- a/tests/ValidationTests.hs +++ b/tests/ValidationTests.hs @@ -19,12 +19,15 @@ import GraphQL.Internal.Validation , getErrors ) -me :: Name -me = "me" +me :: Maybe Name +me = pure "me" someName :: Name someName = "name" +dog :: Name +dog = "dog" + -- | Schema used for these tests. Since none of them do type-level stuff, we -- don't need to define it. schema :: Schema @@ -45,6 +48,41 @@ tests = testSpec "Validation" $ do ] getErrors schema doc `shouldBe` [] + it "Treats anonymous queries as valid" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node (Nothing) [] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [] + + it "Treats anonymous queries with variables as valid" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "Boolean")) + (Just (AST.ValueBoolean True)) + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) + ] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [] + it "Detects duplicate operation names" $ do let doc = AST.QueryDocument [ AST.DefinitionOperation