diff options
25 files changed, 1017 insertions, 401 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 37ac5fe..4ab72fd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,36 @@ The format is based on and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.0.0.0] +### Added +- `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves + insertion order. +- `Language.GraphQL.Schema.schemaWithTypes` constructs a complete schema, + including an optional schema description and user-defined types not referenced + in the schema directly (for example interface implementations). +- `Language.GraphQL.Schema.description` returns the optional schema description. +- All errors that can be associated with a location in the query contain + location information. + +### Fixed +- Parser now accepts empty lists and objects. +- Parser now accepts all directive locations. +- `valuesOfCorrectTypeRule` doesn't check lists recursively since the + validation traverser calls it on all list items. +- `valuesOfCorrectTypeRule` doesn't check objects recursively since the + validation traverser calls it on all object properties. +- Validation of non-nullable values inside lists. +- `executeField` shouldn't assume that a selection has only one field with a + given name, but it should take the first field. The underlying cause is a + wrong pattern, which (because of the laziness) is executed only if the field + has arguments. + +### Changed +- `AST.Document.Value.List` and `AST.Document.ConstValue.ConstList` contain + location information for each list item. +- `Error`: `singleError`, `addErr` and `addErrMsg` are deprecated. They are + internal functions used by the executor for error handling. + ## [0.11.1.0] - 2021-02-07 ### Added - `Validate.Rules`: @@ -104,7 +134,7 @@ and this project adheres to `locations`. - Parsing comments in the front of definitions. - Some missing labels were added to the parsers, some labels were fixed to - refer to the AST nodes being parsed. + refer to the AST nodes being parsed. ### Added - `AST` reexports `AST.Parser`. @@ -413,6 +443,7 @@ and this project adheres to ### Added - Data types for the GraphQL language. +[1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0 [0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0 [0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0 [0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0 diff --git a/graphql.cabal b/graphql.cabal index c06dba4..b67f4ae 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -1,13 +1,7 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.33.0. --- --- see: https://github.com/sol/hpack --- --- hash: 15a0880180192f918ba0bd3b3e955c57232f1efe8993745d505fcb6e1aab1451 - name: graphql -version: 0.11.1.0 +version: 1.0.0.0 synopsis: Haskell GraphQL implementation description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation. category: Language @@ -26,6 +20,7 @@ build-type: Simple extra-source-files: CHANGELOG.md README.md +tested-with: GHC == 8.10.4 source-repository head type: git @@ -43,6 +38,7 @@ library Language.GraphQL.Error Language.GraphQL.Execute Language.GraphQL.Execute.Coerce + Language.GraphQL.Execute.OrderedMap Language.GraphQL.Type Language.GraphQL.Type.In Language.GraphQL.Type.Out @@ -52,6 +48,7 @@ library Test.Hspec.GraphQL other-modules: Language.GraphQL.Execute.Execution + Language.GraphQL.Execute.Internal Language.GraphQL.Execute.Subscribe Language.GraphQL.Execute.Transform Language.GraphQL.Type.Definition @@ -59,19 +56,21 @@ library Language.GraphQL.Validate.Rules hs-source-dirs: src + ghc-options: -Wall build-depends: - aeson - , base >=4.7 && <5 - , conduit - , containers - , exceptions - , hspec-expectations - , megaparsec - , parser-combinators - , scientific - , text - , transformers - , unordered-containers + aeson >= 1.5.6 && < 1.6 + , base >= 4.7 && < 5 + , conduit >= 1.3.4 && < 1.4 + , containers >= 0.6.2 && < 0.7 + , exceptions >= 0.10.4 && < 0.11 + , hspec-expectations >= 0.8.2 && < 0.9 + , megaparsec >= 9.0.1 && < 9.1 + , parser-combinators >= 1.3.0 && < 1.4 + , scientific >= 0.3.7 && < 0.4 + , text >= 1.2.4 && < 1.3 + , transformers >= 0.5.6 && < 0.6 + , unordered-containers >= 0.2.14 && < 0.3 + , vector >= 0.12.3 && < 0.13 default-language: Haskell2010 test-suite graphql-test @@ -84,34 +83,28 @@ test-suite graphql-test Language.GraphQL.AST.ParserSpec Language.GraphQL.ErrorSpec Language.GraphQL.Execute.CoerceSpec + Language.GraphQL.Execute.OrderedMapSpec Language.GraphQL.ExecuteSpec Language.GraphQL.Type.OutSpec Language.GraphQL.Validate.RulesSpec Test.DirectiveSpec Test.FragmentSpec Test.RootOperationSpec - Paths_graphql - autogen-modules: - Paths_graphql hs-source-dirs: tests - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: - QuickCheck + QuickCheck >= 2.14.1 && < 2.15 , aeson - , base >=4.7 && <5 + , base >= 4.7 && < 5 , conduit - , containers , exceptions , graphql - , hspec - , hspec-expectations - , hspec-megaparsec + , hspec >= 2.8.2 && < 2.9 + , hspec-megaparsec >= 2.2.0 && < 2.3 , megaparsec - , parser-combinators - , raw-strings-qq + , raw-strings-qq >= 1.1 && < 1.2 , scientific , text - , transformers , unordered-containers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml deleted file mode 100644 index da9eefd..0000000 --- a/package.yaml +++ /dev/null @@ -1,67 +0,0 @@ -name: graphql -version: 0.11.1.0 -synopsis: Haskell GraphQL implementation -description: - Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation. -maintainer: belka@caraus.de -git: git://caraus.tech/pub/graphql.git -homepage: https://www.caraus.tech/projects/pub-graphql -bug-reports: https://www.caraus.tech/projects/pub-graphql/issues -category: Language -license: MPL-2.0 AND BSD-3-Clause - -copyright: -- (c) 2019-2021 Eugen Wissner -- (c) 2015-2017 J. Daniel Navarro -author: -- Danny Navarro <j@dannynavarro.net> -- Matthías Páll Gissurarson <mpg@mpg.is> -- Sólrún Halla Einarsdóttir <she@mpg.is> - -license-file: -- LICENSE -- LICENSE.MPL -extra-source-files: -- CHANGELOG.md -- README.md - -dependencies: -- aeson -- base >= 4.7 && < 5 -- conduit -- containers -- exceptions -- hspec-expectations -- megaparsec -- parser-combinators -- scientific -- text -- transformers -- unordered-containers - -library: - source-dirs: src - other-modules: - - Language.GraphQL.Execute.Execution - - Language.GraphQL.Execute.Subscribe - - Language.GraphQL.Execute.Transform - - Language.GraphQL.Type.Definition - - Language.GraphQL.Type.Internal - - Language.GraphQL.Validate.Rules - -tests: - graphql-test: - main: Spec.hs - source-dirs: tests - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - graphql - - hspec - - hspec-megaparsec - - QuickCheck - - raw-strings-qq - generated-other-modules: - - Paths_graphql diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index a78b007..a698d2e 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -226,6 +226,12 @@ type TypeCondition = Name -- ** Input Values +-- | Escapes a single character according to the GraphQL escaping rules for +-- double-quoted string values. +-- +-- Characters, that should be escaped, are written as escaped characters with a +-- backslash or Unicode with an \"\\u\". Other characters are returned as +-- strings. escape :: Char -> String escape char' | char' == '\\' = "\\\\" @@ -257,7 +263,7 @@ data Value | Boolean Bool | Null | Enum Name - | List [Value] + | List [Node Value] | Object [ObjectField Value] deriving Eq @@ -281,7 +287,7 @@ data ConstValue | ConstBoolean Bool | ConstNull | ConstEnum Name - | ConstList [ConstValue] + | ConstList [Node ConstValue] | ConstObject [ObjectField ConstValue] deriving Eq @@ -318,13 +324,13 @@ instance Functor ObjectField where -- Each operation can include a list of variables: -- -- @ --- query (protagonist: String = "Zarathustra") { +-- query (protagonist: String = \"Zarathustra\") { -- getAuthor(protagonist: $protagonist) -- } -- @ -- -- This query defines an optional variable @protagonist@ of type @String@, --- its default value is "Zarathustra". If no default value is defined and no +-- its default value is \"Zarathustra\". If no default value is defined and no -- value is provided, a variable can still be @null@ if its type is nullable. -- -- Variables are usually passed along with the query, but not in the query diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index f04f385..0d448df 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -219,7 +219,7 @@ fromConstValue (Full.ConstBoolean x) = Full.Boolean x fromConstValue Full.ConstNull = Full.Null fromConstValue (Full.ConstString string) = Full.String string fromConstValue (Full.ConstEnum x) = Full.Enum x -fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x +fromConstValue (Full.ConstList x) = Full.List $ fmap fromConstValue <$> x fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x where fromConstObjectField Full.ObjectField{value = value', ..} = @@ -266,8 +266,8 @@ stringValue (Pretty indentation) string = = Builder.fromLazyText (indent (indentation + 1)) <> line' <> newline <> acc -listValue :: Formatter -> [Full.Value] -> Lazy.Text -listValue formatter = bracketsCommas formatter $ value formatter +listValue :: Formatter -> [Full.Node Full.Value] -> Lazy.Text +listValue formatter = bracketsCommas formatter $ value formatter . Full.node objectValue :: Formatter -> [Full.ObjectField Full.Value] -> Lazy.Text objectValue formatter = intercalate $ objectField formatter diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 46c8fa3..19251ab 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -14,11 +14,7 @@ import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import qualified Language.GraphQL.AST.DirectiveLocation as Directive -import Language.GraphQL.AST.DirectiveLocation - ( DirectiveLocation - , ExecutableDirectiveLocation - , TypeSystemDirectiveLocation - ) +import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation) import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Lexer import Text.Megaparsec @@ -96,34 +92,28 @@ directiveLocations = optional pipe <?> "DirectiveLocations" directiveLocation :: Parser DirectiveLocation -directiveLocation - = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation - <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation +directiveLocation = e (Directive.Query <$ symbol "QUERY") + <|> e (Directive.Mutation <$ symbol "MUTATION") + <|> e (Directive.Subscription <$ symbol "SUBSCRIPTION") + <|> t (Directive.FieldDefinition <$ symbol "FIELD_DEFINITION") + <|> e (Directive.Field <$ symbol "FIELD") + <|> e (Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION") + <|> e (Directive.FragmentSpread <$ "FRAGMENT_SPREAD") + <|> e (Directive.InlineFragment <$ "INLINE_FRAGMENT") + <|> t (Directive.Schema <$ symbol "SCHEMA") + <|> t (Directive.Scalar <$ symbol "SCALAR") + <|> t (Directive.Object <$ symbol "OBJECT") + <|> t (Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION") + <|> t (Directive.Interface <$ symbol "INTERFACE") + <|> t (Directive.Union <$ symbol "UNION") + <|> t (Directive.EnumValue <$ symbol "ENUM_VALUE") + <|> t (Directive.Enum <$ symbol "ENUM") + <|> t (Directive.InputObject <$ symbol "INPUT_OBJECT") + <|> t (Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION") <?> "DirectiveLocation" - -executableDirectiveLocation :: Parser ExecutableDirectiveLocation -executableDirectiveLocation = Directive.Query <$ symbol "QUERY" - <|> Directive.Mutation <$ symbol "MUTATION" - <|> Directive.Subscription <$ symbol "SUBSCRIPTION" - <|> Directive.Field <$ symbol "FIELD" - <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION" - <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD" - <|> Directive.InlineFragment <$ "INLINE_FRAGMENT" - <?> "ExecutableDirectiveLocation" - -typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation -typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" - <|> Directive.Scalar <$ symbol "SCALAR" - <|> Directive.Object <$ symbol "OBJECT" - <|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION" - <|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION" - <|> Directive.Interface <$ symbol "INTERFACE" - <|> Directive.Union <$ symbol "UNION" - <|> Directive.Enum <$ symbol "ENUM" - <|> Directive.EnumValue <$ symbol "ENUM_VALUE" - <|> Directive.InputObject <$ symbol "INPUT_OBJECT" - <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION" - <?> "TypeSystemDirectiveLocation" + where + e = fmap Directive.ExecutableDirectiveLocation + t = fmap Directive.TypeSystemDirectiveLocation typeDefinition :: Full.Description -> Parser Full.TypeDefinition typeDefinition description' = scalarTypeDefinition description' @@ -460,7 +450,7 @@ value = Full.Variable <$> variable <|> Full.Null <$ nullValue <|> Full.String <$> stringValue <|> Full.Enum <$> try enumValue - <|> Full.List <$> brackets (some value) + <|> Full.List <$> brackets (some $ valueNode value) <|> Full.Object <$> braces (some $ objectField $ valueNode value) <?> "Value" @@ -471,8 +461,8 @@ constValue = Full.ConstFloat <$> try float <|> Full.ConstNull <$ nullValue <|> Full.ConstString <$> stringValue <|> Full.ConstEnum <$> try enumValue - <|> Full.ConstList <$> brackets (some constValue) - <|> Full.ConstObject <$> braces (some $ objectField $ valueNode constValue) + <|> Full.ConstList <$> brackets (many $ valueNode constValue) + <|> Full.ConstObject <$> braces (many $ objectField $ valueNode constValue) <?> "Value" booleanValue :: Parser Bool diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index b084c78..2061c20 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | Error handling. @@ -70,21 +69,25 @@ parseError ParseErrorBundle{..} = type CollectErrsT m = StateT (Resolution m) m -- | Adds an error to the list of errors. +{-# DEPRECATED #-} addErr :: Monad m => Error -> CollectErrsT m () addErr v = modify appender where appender :: Monad m => Resolution m -> Resolution m appender resolution@Resolution{..} = resolution{ errors = errors |> v } +{-# DEPRECATED #-} makeErrorMessage :: Text -> Error makeErrorMessage s = Error s [] [] -- | Constructs a response object containing only the error with the given -- message. +{-# DEPRECATED #-} singleError :: Serialize a => Text -> Response a -singleError message = Response null $ Seq.singleton $ makeErrorMessage message +singleError message = Response null $ Seq.singleton $ Error message [] [] -- | Convenience function for just wrapping an error message. +{-# DEPRECATED #-} addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 283e56c..62754a3 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExplicitForAll #-} -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute @@ -10,15 +10,22 @@ import Control.Monad.Catch (MonadCatch) import Data.HashMap.Strict (HashMap) import Data.Sequence (Seq(..)) import Data.Text (Text) -import Language.GraphQL.AST.Document (Document, Name) +import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Execution +import Language.GraphQL.Execute.Internal import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Execute.Subscribe as Subscribe import Language.GraphQL.Error + ( Error + , ResponseEventStream + , Response(..) + , runCollectErrs + ) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema +import Prelude hiding (null) -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. The operation name can be used if the document @@ -29,35 +36,36 @@ import Language.GraphQL.Type.Schema execute :: (MonadCatch m, VariableValue a, Serialize b) => Schema m -- ^ Resolvers. -> Maybe Text -- ^ Operation name. - -> HashMap Name a -- ^ Variable substitution function. - -> Document -- @GraphQL@ document. + -> HashMap Full.Name a -- ^ Variable substitution function. + -> Full.Document -- @GraphQL@ document. -> m (Either (ResponseEventStream m b) (Response b)) -execute schema' operationName subs document = - case Transform.document schema' operationName subs document of - Left queryError -> pure - $ Right - $ singleError - $ Transform.queryError queryError - Right transformed -> executeRequest transformed +execute schema' operationName subs document + = either (pure . rightErrorResponse . singleError [] . show) executeRequest + $ Transform.document schema' operationName subs document executeRequest :: (MonadCatch m, Serialize a) => Transform.Document m -> m (Either (ResponseEventStream m a) (Response a)) executeRequest (Transform.Document types' rootObjectType operation) - | (Transform.Query _ fields) <- operation = - Right <$> executeOperation types' rootObjectType fields - | (Transform.Mutation _ fields) <- operation = - Right <$> executeOperation types' rootObjectType fields - | (Transform.Subscription _ fields) <- operation - = either (Right . singleError) Left - <$> Subscribe.subscribe types' rootObjectType fields + | (Transform.Query _ fields objectLocation) <- operation = + Right <$> executeOperation types' rootObjectType objectLocation fields + | (Transform.Mutation _ fields objectLocation) <- operation = + Right <$> executeOperation types' rootObjectType objectLocation fields + | (Transform.Subscription _ fields objectLocation) <- operation + = either rightErrorResponse Left + <$> Subscribe.subscribe types' rootObjectType objectLocation fields -- This is actually executeMutation, but we don't distinguish between queries -- and mutations yet. executeOperation :: (MonadCatch m, Serialize a) - => HashMap Name (Type m) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) -> m (Response a) -executeOperation types' objectType fields = - runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields +executeOperation types' objectType objectLocation fields + = runCollectErrs types' + $ executeSelectionSet Definition.Null objectType objectLocation fields + +rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b) +rightErrorResponse = Right . Response null . pure diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 08a2fc0..f5ee204 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -19,7 +19,6 @@ import qualified Data.Aeson as Aeson import Data.Int (Int32) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Map.Strict (Map) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text.Lazy as Text.Lazy @@ -27,6 +26,8 @@ import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder.Int as Text.Builder import Data.Scientific (toBoundedInteger, toRealFloat) import Language.GraphQL.AST (Name) +import Language.GraphQL.Execute.OrderedMap (OrderedMap) +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out @@ -209,7 +210,7 @@ data Output a | Boolean Bool | Enum Name | List [a] - | Object (Map Name a) + | Object (OrderedMap a) deriving (Eq, Show) instance forall a. IsString (Output a) where @@ -229,6 +230,9 @@ instance Serialize Aeson.Value where , Boolean boolean <- value = Just $ Aeson.Bool boolean serialize _ (Enum enum) = Just $ Aeson.String enum serialize _ (List list) = Just $ Aeson.toJSON list - serialize _ (Object object) = Just $ Aeson.toJSON object + serialize _ (Object object) = Just + $ Aeson.object + $ OrderedMap.toList + $ Aeson.toJSON <$> object serialize _ _ = Nothing null = Aeson.Null diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 9d588ca..9ad4439 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -13,16 +14,18 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.State (gets) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map.Strict (Map) +import qualified Data.List.NonEmpty as NonEmpty import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Sequence (Seq(..)) import qualified Data.Text as Text -import Language.GraphQL.AST (Name) +import qualified Language.GraphQL.AST as Full import Language.GraphQL.Error import Language.GraphQL.Execute.Coerce +import Language.GraphQL.Execute.Internal +import Language.GraphQL.Execute.OrderedMap (OrderedMap) +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In @@ -34,15 +37,17 @@ resolveFieldValue :: MonadCatch m => Type.Value -> Type.Subs -> Type.Resolve m + -> Full.Location -> CollectErrsT m Type.Value -resolveFieldValue result args resolver = +resolveFieldValue result args resolver location' = catch (lift $ runReaderT resolver context) handleFieldError where handleFieldError :: MonadCatch m => ResolverException -> CollectErrsT m Type.Value - handleFieldError e = - addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null + handleFieldError e + = addError Type.Null + $ Error (Text.pack $ displayException e) [location'] [] context = Type.Context { Type.arguments = Type.Arguments args , Type.values = result @@ -51,21 +56,21 @@ resolveFieldValue result args resolver = collectFields :: Monad m => Out.ObjectType m -> Seq (Transform.Selection m) - -> Map Name (NonEmpty (Transform.Field m)) -collectFields objectType = foldl forEach Map.empty + -> OrderedMap (NonEmpty (Transform.Field m)) +collectFields objectType = foldl forEach OrderedMap.empty where forEach groupedFields (Transform.SelectionField field) = let responseKey = aliasOrName field - in Map.insertWith (<>) responseKey (field :| []) groupedFields + in OrderedMap.insert responseKey (field :| []) groupedFields forEach groupedFields (Transform.SelectionFragment selectionFragment) | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment , Internal.doesFragmentTypeApply fragmentType objectType = let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet - in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet + in groupedFields <> fragmentGroupedFieldSet | otherwise = groupedFields -aliasOrName :: forall m. Transform.Field m -> Name -aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias +aliasOrName :: forall m. Transform.Field m -> Full.Name +aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias resolveAbstractType :: Monad m => Internal.AbstractType m @@ -95,11 +100,15 @@ executeField fieldResolver prev fields where executeField' fieldDefinition resolver = do let Out.Field _ fieldType argumentDefinitions = fieldDefinition - let (Transform.Field _ _ arguments' _ :| []) = fields + let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields case coerceArgumentValues argumentDefinitions arguments' of - Nothing -> addErrMsg "Argument coercing failed." - Just argumentValues -> do - answer <- resolveFieldValue prev argumentValues resolver + Left [] -> + let errorMessage = "Not all required arguments are specified." + in addError null $ Error errorMessage [location'] [] + Left errorLocations -> addError null + $ Error "Argument coercing failed." errorLocations [] + Right argumentValues -> do + answer <- resolveFieldValue prev argumentValues resolver location' completeValue fieldType fields answer completeValue :: (MonadCatch m, Serialize a) @@ -110,55 +119,67 @@ completeValue :: (MonadCatch m, Serialize a) completeValue (Out.isNonNullType -> False) _ Type.Null = pure null completeValue outputType@(Out.ListBaseType listType) fields (Type.List list) = traverse (completeValue listType fields) list - >>= coerceResult outputType . List -completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) = - coerceResult outputType $ Int int -completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) = - coerceResult outputType $ Boolean boolean -completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) = - coerceResult outputType $ Float float -completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) = - coerceResult outputType $ String string -completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) = + >>= coerceResult outputType (firstFieldLocation fields) . List +completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) = + coerceResult outputType (firstFieldLocation fields) $ Int int +completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) = + coerceResult outputType (firstFieldLocation fields) $ Boolean boolean +completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) = + coerceResult outputType (firstFieldLocation fields) $ Float float +completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) = + coerceResult outputType (firstFieldLocation fields) $ String string +completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) = let Type.EnumType _ _ enumMembers = enumType + location = firstFieldLocation fields in if HashMap.member enum enumMembers - then coerceResult outputType $ Enum enum - else addErrMsg "Enum value completion failed." -completeValue (Out.ObjectBaseType objectType) fields result = - executeSelectionSet result objectType $ mergeSelectionSets fields + then coerceResult outputType location $ Enum enum + else addError null $ Error "Enum value completion failed." [location] [] +completeValue (Out.ObjectBaseType objectType) fields result + = executeSelectionSet result objectType (firstFieldLocation fields) + $ mergeSelectionSets fields completeValue (Out.InterfaceBaseType interfaceType) fields result | Type.Object objectMap <- result = do let abstractType = Internal.AbstractInterfaceType interfaceType + let location = firstFieldLocation fields concreteType <- resolveAbstractType abstractType objectMap case concreteType of - Just objectType -> executeSelectionSet result objectType + Just objectType -> executeSelectionSet result objectType location $ mergeSelectionSets fields - Nothing -> addErrMsg "Interface value completion failed." + Nothing -> addError null + $ Error "Interface value completion failed." [location] [] completeValue (Out.UnionBaseType unionType) fields result | Type.Object objectMap <- result = do let abstractType = Internal.AbstractUnionType unionType + let location = firstFieldLocation fields concreteType <- resolveAbstractType abstractType objectMap case concreteType of Just objectType -> executeSelectionSet result objectType - $ mergeSelectionSets fields - Nothing -> addErrMsg "Union value completion failed." -completeValue _ _ _ = addErrMsg "Value completion failed." + location $ mergeSelectionSets fields + Nothing -> addError null + $ Error "Union value completion failed." [location] [] +completeValue _ (Transform.Field _ _ _ _ location :| _) _ = + addError null $ Error "Value completion failed." [location] [] mergeSelectionSets :: MonadCatch m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m) mergeSelectionSets = foldr forEach mempty where - forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet = + forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet = selectionSet <> fieldSelectionSet +firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location +firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation + coerceResult :: (MonadCatch m, Serialize a) => Out.Type m + -> Full.Location -> Output a -> CollectErrsT m a -coerceResult outputType result +coerceResult outputType parentLocation result | Just serialized <- serialize outputType result = pure serialized - | otherwise = addErrMsg "Result coercion failed." + | otherwise = addError null + $ Error "Result coercion failed." [parentLocation] [] -- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies -- each field to each 'Transform.Selection'. Resolves into a value containing @@ -166,29 +187,45 @@ coerceResult outputType result executeSelectionSet :: (MonadCatch m, Serialize a) => Type.Value -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) -> CollectErrsT m a -executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do +executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do let fields = collectFields objectType selectionSet - resolvedValues <- Map.traverseMaybeWithKey forEach fields - coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues + resolvedValues <- OrderedMap.traverseMaybe forEach fields + coerceResult (Out.NonNullObjectType objectType) objectLocation + $ Object resolvedValues where - forEach _ fields@(field :| _) = - let Transform.Field _ name _ _ = field + forEach fields@(field :| _) = + let Transform.Field _ name _ _ _ = field in traverse (tryResolver fields) $ lookupResolver name lookupResolver = flip HashMap.lookup resolvers tryResolver fields resolver = executeField resolver result fields >>= lift . pure coerceArgumentValues - :: HashMap Name In.Argument - -> HashMap Name Transform.Input - -> Maybe Type.Subs -coerceArgumentValues argumentDefinitions argumentValues = + :: HashMap Full.Name In.Argument + -> HashMap Full.Name (Full.Node Transform.Input) + -> Either [Full.Location] Type.Subs +coerceArgumentValues argumentDefinitions argumentNodes = HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions where - forEach variableName (In.Argument _ variableType defaultValue) = - matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue + forEach argumentName (In.Argument _ variableType defaultValue) = \case + Right resultMap + | Just matchedValues + <- matchFieldValues' argumentName variableType defaultValue $ Just resultMap + -> Right matchedValues + | otherwise -> Left $ generateError argumentName [] + Left errorLocations + | Just _ + <- matchFieldValues' argumentName variableType defaultValue $ pure mempty + -> Left errorLocations + | otherwise -> Left $ generateError argumentName errorLocations + generateError argumentName errorLocations = + case HashMap.lookup argumentName argumentNodes of + Just (Full.Node _ errorLocation) -> [errorLocation] + Nothing -> errorLocations + matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes) coerceArgumentValue inputType (Transform.Int integer) = coerceInputLiteral inputType (Type.Int integer) coerceArgumentValue inputType (Transform.Boolean boolean) = diff --git a/src/Language/GraphQL/Execute/Internal.hs b/src/Language/GraphQL/Execute/Internal.hs new file mode 100644 index 0000000..046db45 --- /dev/null +++ b/src/Language/GraphQL/Execute/Internal.hs @@ -0,0 +1,31 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + 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 DuplicateRecordFields #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Language.GraphQL.Execute.Internal + ( addError + , singleError + ) where + +import Control.Monad.Trans.State (modify) +import Control.Monad.Catch (MonadCatch) +import Data.Sequence ((|>)) +import qualified Data.Text as Text +import qualified Language.GraphQL.AST as Full +import Language.GraphQL.Error (CollectErrsT, Error(..), Resolution(..)) +import Prelude hiding (null) + +addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a +addError returnValue error' = modify appender >> pure returnValue + where + appender :: Resolution m -> Resolution m + appender resolution@Resolution{ errors } = resolution + { errors = errors |> error' + } + +singleError :: [Full.Location] -> String -> Error +singleError errorLocations message = Error (Text.pack message) errorLocations [] diff --git a/src/Language/GraphQL/Execute/OrderedMap.hs b/src/Language/GraphQL/Execute/OrderedMap.hs new file mode 100644 index 0000000..e905cce --- /dev/null +++ b/src/Language/GraphQL/Execute/OrderedMap.hs @@ -0,0 +1,148 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + 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 ExplicitForAll #-} + +-- | This module contains a map data structure, that preserves insertion order. +-- Some definitions conflict with functions from prelude, so this module should +-- probably be imported qualified. +module Language.GraphQL.Execute.OrderedMap + ( OrderedMap + , elems + , empty + , insert + , foldlWithKey' + , keys + , lookup + , replace + , singleton + , size + , toList + , traverseMaybe + ) where + +import qualified Data.Foldable as Foldable +import Data.HashMap.Strict (HashMap, (!)) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Prelude hiding (filter, lookup) + +-- | This map associates values with the given text keys. Insertion order is +-- preserved. When inserting a value with a key, that is already available in +-- the map, the existing value isn't overridden, but combined with the new value +-- using its 'Semigroup' instance. +-- +-- Internally this map uses an array with keys to preserve the order and an +-- unorded map with key-value pairs. +data OrderedMap v = OrderedMap (Vector Text) (HashMap Text v) + deriving (Eq) + +instance Functor OrderedMap where + fmap f (OrderedMap vector hashMap) = OrderedMap vector $ fmap f hashMap + +instance Foldable OrderedMap where + foldr f = foldrWithKey $ const f + null (OrderedMap vector _) = Vector.null vector + +instance Semigroup v => Semigroup (OrderedMap v) where + (<>) = foldlWithKey' + $ \accumulator key value -> insert key value accumulator + +instance Semigroup v => Monoid (OrderedMap v) where + mempty = empty + +instance Traversable OrderedMap where + traverse f (OrderedMap vector hashMap) = OrderedMap vector + <$> traverse f hashMap + +instance Show v => Show (OrderedMap v) where + showsPrec precedence map' = showParen (precedence > 10) + $ showString "fromList " . shows (toList map') + +-- * Construction + +-- | Constructs a map with a single element. +singleton :: forall v. Text -> v -> OrderedMap v +singleton key value = OrderedMap (Vector.singleton key) + $ HashMap.singleton key value + +-- | Constructs an empty map. +empty :: forall v. OrderedMap v +empty = OrderedMap mempty mempty + +-- * Traversal + +-- | Reduces this map by applying a binary operator from right to left to all +-- elements, using the given starting value. +foldrWithKey :: forall v a. (Text -> v -> a -> a) -> a -> OrderedMap v -> a +foldrWithKey f initial (OrderedMap vector hashMap) = foldr go initial vector + where + go key = f key (hashMap ! key) + +-- | Reduces this map by applying a binary operator from left to right to all +-- elements, using the given starting value. +foldlWithKey' :: forall v a. (a -> Text -> v -> a) -> a -> OrderedMap v -> a +foldlWithKey' f initial (OrderedMap vector hashMap) = + Vector.foldl' go initial vector + where + go accumulator key = f accumulator key (hashMap ! key) + +-- | Traverse over the elements and collect the 'Just' results. +traverseMaybe + :: Applicative f + => forall a + . (a -> f (Maybe b)) + -> OrderedMap a + -> f (OrderedMap b) +traverseMaybe f orderedMap = foldlWithKey' filter empty + <$> traverse f orderedMap + where + filter accumulator key (Just value) = replace key value accumulator + filter accumulator _ Nothing = accumulator + +-- * Lists + +-- | Converts this map to the list of key-value pairs. +toList :: forall v. OrderedMap v -> [(Text, v)] +toList = foldrWithKey ((.) (:) . (,)) [] + +-- | Returns a list with all keys in this map. +keys :: forall v. OrderedMap v -> [Text] +keys (OrderedMap vector _) = Foldable.toList vector + +-- | Returns a list with all elements in this map. +elems :: forall v. OrderedMap v -> [v] +elems = fmap snd . toList + +-- * Basic interface + +-- | Associates the specified value with the specified key in this map. If this +-- map previously contained a mapping for the key, the existing and new values +-- are combined. +insert :: Semigroup v => Text -> v -> OrderedMap v -> OrderedMap v +insert key value (OrderedMap vector hashMap) + | Just available <- HashMap.lookup key hashMap = OrderedMap vector + $ HashMap.insert key (available <> value) hashMap + | otherwise = OrderedMap (Vector.snoc vector key) + $ HashMap.insert key value hashMap + +-- | Associates the specified value with the specified key in this map. If this +-- map previously contained a mapping for the key, the existing value is +-- replaced by the new one. +replace :: Text -> v -> OrderedMap v -> OrderedMap v +replace key value (OrderedMap vector hashMap) + | HashMap.member key hashMap = OrderedMap vector + $ HashMap.insert key value hashMap + | otherwise = OrderedMap (Vector.snoc vector key) + $ HashMap.insert key value hashMap + +-- | Gives the size of this map, i.e. number of elements in it. +size :: forall v. OrderedMap v -> Int +size (OrderedMap vector _) = Vector.length vector + +-- | Looks up a value in this map by key. +lookup :: forall v. Text -> OrderedMap v -> Maybe v +lookup key (OrderedMap _ hashMap) = HashMap.lookup key hashMap diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs index 0bd274f..5d8d294 100644 --- a/src/Language/GraphQL/Execute/Subscribe.hs +++ b/src/Language/GraphQL/Execute/Subscribe.hs @@ -9,62 +9,78 @@ module Language.GraphQL.Execute.Subscribe ) where import Conduit +import Control.Arrow (left) import Control.Monad.Catch (Exception(..), MonadCatch(..)) import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map.Strict as Map import qualified Data.List.NonEmpty as NonEmpty import Data.Sequence (Seq(..)) -import Data.Text (Text) -import qualified Data.Text as Text -import Language.GraphQL.AST (Name) +import qualified Language.GraphQL.AST as Full import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Execution +import Language.GraphQL.Execute.Internal +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error + ( Error(..) + , ResolverException + , Response + , ResponseEventStream + , runCollectErrs + ) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema --- This is actually executeMutation, but we don't distinguish between queries --- and mutations yet. subscribe :: (MonadCatch m, Serialize a) - => HashMap Name (Type m) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) - -> m (Either Text (ResponseEventStream m a)) -subscribe types' objectType fields = do - sourceStream <- createSourceEventStream types' objectType fields - traverse (mapSourceToResponseEvent types' objectType fields) sourceStream + -> m (Either Error (ResponseEventStream m a)) +subscribe types' objectType objectLocation fields = do + sourceStream <- + createSourceEventStream types' objectType objectLocation fields + let traverser = + mapSourceToResponseEvent types' objectType objectLocation fields + traverse traverser sourceStream mapSourceToResponseEvent :: (MonadCatch m, Serialize a) - => HashMap Name (Type m) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) -> Out.SourceEventStream m -> m (ResponseEventStream m a) -mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure +mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream + = pure $ sourceStream - .| mapMC (executeSubscriptionEvent types' subscriptionType fields) + .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields) createSourceEventStream :: MonadCatch m - => HashMap Name (Type m) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) - -> m (Either Text (Out.SourceEventStream m)) -createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields - | [fieldGroup] <- Map.elems groupedFieldSet - , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup + -> m (Either Error (Out.SourceEventStream m)) +createSourceEventStream _types subscriptionType objectLocation fields + | [fieldGroup] <- OrderedMap.elems groupedFieldSet + , Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup + , Out.ObjectType _ _ _ fieldTypes <- subscriptionType , resolverT <- fieldTypes HashMap.! fieldName , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition = case coerceArgumentValues argumentDefinitions arguments' of - Nothing -> pure $ Left "Argument coercion failed." - Just argumentValues -> - resolveFieldEventStream Type.Null argumentValues resolver - | otherwise = pure $ Left "Subscription contains more than one field." + Left _ -> pure + $ Left + $ Error "Argument coercion failed." [errorLocation] [] + Right argumentValues -> left (singleError [errorLocation]) + <$> resolveFieldEventStream Type.Null argumentValues resolver + | otherwise = pure + $ Left + $ Error "Subscription contains more than one field." [objectLocation] [] where groupedFieldSet = collectFields subscriptionType fields @@ -72,26 +88,26 @@ resolveFieldEventStream :: MonadCatch m => Type.Value -> Type.Subs -> Out.Subscribe m - -> m (Either Text (Out.SourceEventStream m)) + -> m (Either String (Out.SourceEventStream m)) resolveFieldEventStream result args resolver = catch (Right <$> runReaderT resolver context) handleEventStreamError where handleEventStreamError :: MonadCatch m => ResolverException - -> m (Either Text (Out.SourceEventStream m)) - handleEventStreamError = pure . Left . Text.pack . displayException + -> m (Either String (Out.SourceEventStream m)) + handleEventStreamError = pure . Left . displayException context = Type.Context { Type.arguments = Type.Arguments args , Type.values = result } --- This is actually executeMutation, but we don't distinguish between queries --- and mutations yet. executeSubscriptionEvent :: (MonadCatch m, Serialize a) - => HashMap Name (Type m) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) -> Definition.Value -> m (Response a) -executeSubscriptionEvent types' objectType fields initialValue = - runCollectErrs types' $ executeSelectionSet initialValue objectType fields +executeSubscriptionEvent types' objectType objectLocation fields initialValue + = runCollectErrs types' + $ executeSelectionSet initialValue objectType objectLocation fields diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 010899b..117b708 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -1,3 +1,7 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + 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 ExplicitForAll #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -25,7 +29,6 @@ module Language.GraphQL.Execute.Transform , QueryError(..) , Selection(..) , document - , queryError ) where import Control.Monad (foldM, unless) @@ -71,16 +74,18 @@ data Selection m | SelectionField (Field m) -- | GraphQL has 3 operation types: queries, mutations and subscribtions. --- --- Currently only queries and mutations are supported. data Operation m - = Query (Maybe Text) (Seq (Selection m)) - | Mutation (Maybe Text) (Seq (Selection m)) - | Subscription (Maybe Text) (Seq (Selection m)) + = Query (Maybe Text) (Seq (Selection m)) Full.Location + | Mutation (Maybe Text) (Seq (Selection m)) Full.Location + | Subscription (Maybe Text) (Seq (Selection m)) Full.Location -- | Single GraphQL field. data Field m = Field - (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m)) + (Maybe Full.Name) + Full.Name + (HashMap Full.Name (Full.Node Input)) + (Seq (Selection m)) + Full.Location -- | Contains the operation to be executed along with its root type. data Document m = Document @@ -92,16 +97,26 @@ data OperationDefinition = OperationDefinition [Full.VariableDefinition] [Full.Directive] Full.SelectionSet + Full.Location -- | Query error types. data QueryError = OperationNotFound Text | OperationNameRequired | CoercionError - | TransformationError | EmptyDocument | UnsupportedRootOperation +instance Show QueryError where + show (OperationNotFound operationName) = unwords + ["Operation", Text.unpack operationName, "couldn't be found in the document."] + show OperationNameRequired = "Missing operation name." + show CoercionError = "Coercion error." + show EmptyDocument = + "The document doesn't contain any executable operations." + show UnsupportedRootOperation = + "Root operation type couldn't be found in the schema." + data Input = Int Int32 | Float Double @@ -114,17 +129,6 @@ data Input | Variable Type.Value deriving (Eq, Show) -queryError :: QueryError -> Text -queryError (OperationNotFound operationName) = Text.unwords - ["Operation", operationName, "couldn't be found in the document."] -queryError OperationNameRequired = "Missing operation name." -queryError CoercionError = "Coercion error." -queryError TransformationError = "Schema transformation error." -queryError EmptyDocument = - "The document doesn't contain any executable operations." -queryError UnsupportedRootOperation = - "Root operation type couldn't be found in the schema." - getOperation :: Maybe Full.Name -> NonEmpty OperationDefinition @@ -135,7 +139,7 @@ getOperation (Just operationName) operations | Just operation' <- find matchingName operations = pure operation' | otherwise = Left $ OperationNotFound operationName where - matchingName (OperationDefinition _ name _ _ _) = + matchingName (OperationDefinition _ name _ _ _ _) = name == Just operationName coerceVariableValues :: Coerce.VariableValue a @@ -145,7 +149,7 @@ coerceVariableValues :: Coerce.VariableValue a -> HashMap.HashMap Full.Name a -> Either QueryError Type.Subs coerceVariableValues types operationDefinition variableValues = - let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition + let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition in maybe (Left CoercionError) Right $ foldr forEach (Just HashMap.empty) variableDefinitions where @@ -173,7 +177,7 @@ constValue (Full.ConstString x) = Type.String x constValue (Full.ConstBoolean b) = Type.Boolean b constValue Full.ConstNull = Type.Null constValue (Full.ConstEnum e) = Type.Enum e -constValue (Full.ConstList l) = Type.List $ constValue <$> l +constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list constValue (Full.ConstObject o) = Type.Object $ HashMap.fromList $ constObjectField <$> o where @@ -203,14 +207,14 @@ document schema operationName subs ast = do , types = referencedTypes } case chosenOperation of - OperationDefinition Full.Query _ _ _ _ -> + OperationDefinition Full.Query _ _ _ _ _ -> pure $ Document referencedTypes (Schema.query schema) $ operation chosenOperation replacement - OperationDefinition Full.Mutation _ _ _ _ + OperationDefinition Full.Mutation _ _ _ _ _ | Just mutationType <- Schema.mutation schema -> pure $ Document referencedTypes mutationType $ operation chosenOperation replacement - OperationDefinition Full.Subscription _ _ _ _ + OperationDefinition Full.Subscription _ _ _ _ _ | Just subscriptionType <- Schema.subscription schema -> pure $ Document referencedTypes subscriptionType $ operation chosenOperation replacement @@ -235,10 +239,10 @@ defragment ast = (operations, HashMap.insert name fragment fragments') defragment' _ acc = acc transform = \case - Full.OperationDefinition type' name variables directives' selections _ -> - OperationDefinition type' name variables directives' selections - Full.SelectionSet selectionSet _ -> - OperationDefinition Full.Query Nothing mempty mempty selectionSet + Full.OperationDefinition type' name variables directives' selections location -> + OperationDefinition type' name variables directives' selections location + Full.SelectionSet selectionSet location -> + OperationDefinition Full.Query Nothing mempty mempty selectionSet location -- * Operation @@ -247,12 +251,12 @@ operation operationDefinition replacement = runIdentity $ evalStateT (collectFragments >> transform operationDefinition) replacement where - transform (OperationDefinition Full.Query name _ _ sels) = - Query name <$> appendSelection sels - transform (OperationDefinition Full.Mutation name _ _ sels) = - Mutation name <$> appendSelection sels - transform (OperationDefinition Full.Subscription name _ _ sels) = - Subscription name <$> appendSelection sels + transform (OperationDefinition Full.Query name _ _ sels location) = + flip (Query name) location <$> appendSelection sels + transform (OperationDefinition Full.Mutation name _ _ sels location) = + flip (Mutation name) location <$> appendSelection sels + transform (OperationDefinition Full.Subscription name _ _ sels location) = + flip (Subscription name) location <$> appendSelection sels -- * Selection @@ -268,15 +272,20 @@ selection (Full.InlineFragmentSelection fragmentSelection) = inlineFragment fragmentSelection field :: Full.Field -> State (Replacement m) (Maybe (Field m)) -field (Full.Field alias name arguments' directives' selections _) = do +field (Full.Field alias name arguments' directives' selections location) = do fieldArguments <- foldM go HashMap.empty arguments' fieldSelections <- appendSelection selections fieldDirectives <- Definition.selection <$> directives directives' - let field' = Field alias name fieldArguments fieldSelections + let field' = Field alias name fieldArguments fieldSelections location pure $ field' <$ fieldDirectives where - go arguments (Full.Argument name' (Full.Node value' _) _) = - inputField arguments name' value' + go arguments (Full.Argument name' (Full.Node value' _) location') = do + objectFieldValue <- input value' + case objectFieldValue of + Just fieldValue -> + let argumentNode = Full.Node fieldValue location' + in pure $ HashMap.insert name' argumentNode arguments + Nothing -> pure arguments fragmentSpread :: Full.FragmentSpread @@ -380,7 +389,7 @@ value (Full.String string) = pure $ Type.String string value (Full.Boolean boolean) = pure $ Type.Boolean boolean value Full.Null = pure Type.Null value (Full.Enum enum) = pure $ Type.Enum enum -value (Full.List list) = Type.List <$> traverse value list +value (Full.List list) = Type.List <$> traverse (value . Full.node) list value (Full.Object object) = Type.Object . HashMap.fromList <$> traverse objectField object where @@ -396,7 +405,7 @@ input (Full.String string) = pure $ pure $ String string input (Full.Boolean boolean) = pure $ pure $ Boolean boolean input Full.Null = pure $ pure Null input (Full.Enum enum) = pure $ pure $ Enum enum -input (Full.List list) = pure . List <$> traverse value list +input (Full.List list) = pure . List <$> traverse (value . Full.node) list input (Full.Object object) = do objectFields <- foldM objectField HashMap.empty object pure $ pure $ Object objectFields diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index 3ed8bb9..8a2a4d1 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -21,6 +21,6 @@ module Language.GraphQL.Type ) where import Language.GraphQL.Type.Definition -import Language.GraphQL.Type.Schema (Schema, schema) +import Language.GraphQL.Type.Schema (Schema, schema, schemaWithTypes) import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 2081b97..ce3b121 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -12,6 +12,7 @@ module Language.GraphQL.Type.Internal , Directives , Schema(..) , Type(..) + , description , directives , doesFragmentTypeApply , implementations @@ -55,41 +56,43 @@ type Directives = HashMap Full.Name Directive -- | A Schema is created by supplying the root types of each type of operation, -- query and mutation (optional). A schema definition is then supplied to the -- validator and executor. --- --- __Note:__ When the schema is constructed, by default only the types that --- are reachable by traversing the root types are included, other types must --- be explicitly referenced. data Schema m = Schema - (Out.ObjectType m) - (Maybe (Out.ObjectType m)) - (Maybe (Out.ObjectType m)) - Directives - (HashMap Full.Name (Type m)) + (Maybe Text) -- ^ Description. + (Out.ObjectType m) -- ^ Query. + (Maybe (Out.ObjectType m)) -- ^ Mutation. + (Maybe (Out.ObjectType m)) -- ^ Subscription. + Directives -- ^ Directives + (HashMap Full.Name (Type m)) -- ^ Types. + -- Interface implementations (used only for faster access). (HashMap Full.Name [Type m]) +-- | Schema description. +description :: forall m. Schema m -> Maybe Text +description (Schema description' _ _ _ _ _ _) = description' + -- | Schema query type. query :: forall m. Schema m -> Out.ObjectType m -query (Schema query' _ _ _ _ _) = query' +query (Schema _ query' _ _ _ _ _) = query' -- | Schema mutation type. mutation :: forall m. Schema m -> Maybe (Out.ObjectType m) -mutation (Schema _ mutation' _ _ _ _) = mutation' +mutation (Schema _ _ mutation' _ _ _ _) = mutation' -- | Schema subscription type. subscription :: forall m. Schema m -> Maybe (Out.ObjectType m) -subscription (Schema _ _ subscription' _ _ _) = subscription' +subscription (Schema _ _ _ subscription' _ _ _) = subscription' -- | Schema directive definitions. directives :: forall m. Schema m -> Directives -directives (Schema _ _ _ directives' _ _) = directives' +directives (Schema _ _ _ _ directives' _ _) = directives' -- | Types referenced by the schema. types :: forall m. Schema m -> HashMap Full.Name (Type m) -types (Schema _ _ _ _ types' _) = types' +types (Schema _ _ _ _ _ types' _) = types' -- | Interface implementations. implementations :: forall m. Schema m -> HashMap Full.Name [Type m] -implementations (Schema _ _ _ _ _ implementations') = implementations' +implementations (Schema _ _ _ _ _ _ implementations') = implementations' -- | These types may describe the parent context of a selection set. data CompositeType m diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index dae8e18..ddddb4a 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -9,11 +9,13 @@ -- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema ( schema + , schemaWithTypes , module Language.GraphQL.Type.Internal ) where import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation import qualified Language.GraphQL.AST as Full @@ -22,6 +24,7 @@ import Language.GraphQL.Type.Internal , Directives , Schema , Type(..) + , description , directives , implementations , mutation @@ -35,17 +38,47 @@ import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out -- | Schema constructor. +-- +-- __Note:__ When the schema is constructed, by default only the types that +-- are reachable by traversing the root types are included, other types must +-- be explicitly referenced using 'schemaWithTypes' instead. schema :: forall m . Out.ObjectType m -- ^ Query type. -> Maybe (Out.ObjectType m) -- ^ Mutation type. -> Maybe (Out.ObjectType m) -- ^ Subscription type. -> Directives -- ^ Directive definitions. -> Schema m -- ^ Schema. -schema queryRoot mutationRoot subscriptionRoot directiveDefinitions = - Internal.Schema queryRoot mutationRoot subscriptionRoot +schema queryRoot mutationRoot subscriptionRoot = + schemaWithTypes Nothing queryRoot mutationRoot subscriptionRoot mempty + +-- | Constructs a complete schema, including user-defined types not referenced +-- in the schema directly (for example interface implementations). +schemaWithTypes :: forall m + . Maybe Text -- ^ Schema description + -> Out.ObjectType m -- ^ Query type. + -> Maybe (Out.ObjectType m) -- ^ Mutation type. + -> Maybe (Out.ObjectType m) -- ^ Subscription type. + -> [Type m] -- ^ Additional types. + -> Directives -- ^ Directive definitions. + -> Schema m -- ^ Schema. +schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' directiveDefinitions = + Internal.Schema description' queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes collectedImplementations where - collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot + allTypes = foldr addTypeDefinition HashMap.empty types' + addTypeDefinition type'@(ScalarType (Definition.ScalarType typeName _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(EnumType (Definition.EnumType typeName _ _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(ObjectType (Out.ObjectType typeName _ _ _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(InputObjectType (In.InputObjectType typeName _ _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(InterfaceType (Out.InterfaceType typeName _ _ _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(UnionType (Out.UnionType typeName _ _)) accumulator = + HashMap.insert typeName type' accumulator + collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot allTypes collectedImplementations = collectImplementations collectedTypes allDirectives = HashMap.union directiveDefinitions defaultDirectives defaultDirectives = HashMap.fromList @@ -98,11 +131,12 @@ collectReferencedTypes :: forall m -> Maybe (Out.ObjectType m) -> Maybe (Out.ObjectType m) -> HashMap Full.Name (Type m) -collectReferencedTypes queryRoot mutationRoot subscriptionRoot = - let queryTypes = traverseObjectType queryRoot HashMap.empty + -> HashMap Full.Name (Type m) +collectReferencedTypes queryRoot mutationRoot subscriptionRoot extraTypes = + let queryTypes = traverseObjectType queryRoot extraTypes mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) mutationRoot - in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot + in maybe mutationTypes (`traverseObjectType` mutationTypes) subscriptionRoot where collect traverser typeName element foundTypes | HashMap.member typeName foundTypes = foundTypes diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index ea72018..f929b98 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -4,7 +4,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | GraphQL validator. @@ -315,9 +314,6 @@ constValue (Validation.ValueRule _ rule) valueType = go valueType go inputObjectType value'@(Full.Node (Full.ConstObject fields) _) = foldMap (forEach inputObjectType) (Seq.fromList fields) |> rule inputObjectType value' - go listType value'@(Full.Node (Full.ConstList values) location') - = embedListLocation go listType values location' - |> rule listType value' go anotherValue value' = pure $ rule anotherValue value' forEach inputObjectType Full.ObjectField{value = value', ..} = go (valueTypeByName name inputObjectType) value' @@ -421,20 +417,6 @@ argument rule argumentType (Full.Argument _ value' _) = where valueType (In.Argument _ valueType' _) = valueType' --- valueTypeFromList :: Maybe In.Type -> Maybe In.Type -embedListLocation :: forall a m - . (Maybe In.Type -> Full.Node a -> Seq m) - -> Maybe In.Type - -> [a] - -> Full.Location - -> Seq m -embedListLocation go listType values location' - = foldMap (go $ valueTypeFromList listType) - $ flip Full.Node location' <$> Seq.fromList values - where - valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType - valueTypeFromList _ = Nothing - value :: forall m . Validation.Rule m -> Maybe In.Type @@ -445,9 +427,6 @@ value (Validation.ValueRule rule _) valueType = go valueType go inputObjectType value'@(Full.Node (Full.Object fields) _) = foldMap (forEach inputObjectType) (Seq.fromList fields) |> rule inputObjectType value' - go listType value'@(Full.Node (Full.List values) location') - = embedListLocation go listType values location' - |> rule listType value' go anotherValue value' = pure $ rule anotherValue value' forEach inputObjectType Full.ObjectField{value = value', ..} = go (valueTypeByName name inputObjectType) value' diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 71455d3..46a14b7 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -1502,15 +1502,6 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case hasNonNullVariableDefaultValue (Just (Full.Node Full.ConstNull _)) = False hasNonNullVariableDefaultValue Nothing = False hasNonNullVariableDefaultValue _ = True - unwrapInType (In.NonNullScalarType nonNullType) = - Just $ In.NamedScalarType nonNullType - unwrapInType (In.NonNullEnumType nonNullType) = - Just $ In.NamedEnumType nonNullType - unwrapInType (In.NonNullInputObjectType nonNullType) = - Just $ In.NamedInputObjectType nonNullType - unwrapInType (In.NonNullListType nonNullType) = - Just $ In.ListType nonNullType - unwrapInType _ = Nothing makeError variableDefinition expectedType = let Full.VariableDefinition variableName variableType _ location' = variableDefinition @@ -1527,6 +1518,17 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case , locations = [location'] } +unwrapInType :: In.Type -> Maybe In.Type +unwrapInType (In.NonNullScalarType nonNullType) = + Just $ In.NamedScalarType nonNullType +unwrapInType (In.NonNullEnumType nonNullType) = + Just $ In.NamedEnumType nonNullType +unwrapInType (In.NonNullInputObjectType nonNullType) = + Just $ In.NamedInputObjectType nonNullType +unwrapInType (In.NonNullListType nonNullType) = + Just $ In.ListType nonNullType +unwrapInType _ = Nothing + -- | Literal values must be compatible with the type expected in the position -- they are found as per the coercion rules. -- @@ -1540,7 +1542,7 @@ valuesOfCorrectTypeRule = ValueRule go constGo go (Just inputType) value | Just constValue <- toConstNode value = lift $ check inputType constValue - go _ _ = lift mempty + go _ _ = lift mempty -- This rule checks only literals. toConstNode Full.Node{..} = flip Full.Node location <$> toConst node toConst (Full.Variable _) = Nothing toConst (Full.Int integer) = Just $ Full.ConstInt integer @@ -1550,7 +1552,7 @@ valuesOfCorrectTypeRule = ValueRule go constGo toConst Full.Null = Just Full.ConstNull toConst (Full.Enum enum) = Just $ Full.ConstEnum enum toConst (Full.List values) = - Just $ Full.ConstList $ catMaybes $ toConst <$> values + Just $ Full.ConstList $ catMaybes $ toConstNode <$> values toConst (Full.Object fields) = Just $ Full.ConstObject $ catMaybes $ constObjectField <$> fields constObjectField Full.ObjectField{..} @@ -1582,24 +1584,37 @@ valuesOfCorrectTypeRule = ValueRule go constGo , Full.ConstEnum memberValue <- node , HashMap.member memberValue members = mempty check (In.InputObjectBaseType objectType) Full.Node{ node } - | In.InputObjectType _ _ typeFields <- objectType - , Full.ConstObject valueFields <- node = - foldMap (checkObjectField typeFields) valueFields + -- Skip, objects are checked recursively by the validation traverser. + | In.InputObjectType{} <- objectType + , Full.ConstObject{} <- node = mempty check (In.ListBaseType listType) constValue@Full.Node{ .. } - | Full.ConstList listValues <- node = - foldMap (check listType) $ flip Full.Node location <$> listValues + | Full.ConstList values <- node = + foldMap (checkNull listType) values | otherwise = check listType constValue check inputType Full.Node{ .. } = pure $ Error { message = concat [ "Value " - , show node, " cannot be coerced to type \"" + , show node + , " cannot be coerced to type \"" , show inputType , "\"." ] , locations = [location] } - checkObjectField typeFields Full.ObjectField{..} - | Just typeField <- HashMap.lookup name typeFields - , In.InputField _ fieldType _ <- typeField = - check fieldType value - checkObjectField _ _ = mempty + checkNull inputType constValue = + let checkResult = check inputType constValue + in case null checkResult of + True + | Just unwrappedType <- unwrapInType inputType + , Full.Node{ node = Full.ConstNull, .. } <- constValue -> + pure $ Error + { message = concat + [ "List of non-null values of type \"" + , show unwrappedType + , "\" cannot contain null values." + ] + , locations = [location] + } + | otherwise -> mempty + _ -> checkResult + diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index b7b9ac3..0000000 --- a/stack.yaml +++ /dev/null @@ -1,9 +0,0 @@ -resolver: lts-17.2 - -packages: -- . - -extra-deps: [] -flags: {} - -pvp-bounds: lower diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index 5c4d39e..a47fc11 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -6,6 +6,7 @@ module Language.GraphQL.AST.ParserSpec import Data.List.NonEmpty (NonEmpty(..)) import Language.GraphQL.AST.Document +import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc import Language.GraphQL.AST.Parser import Test.Hspec (Spec, describe, it) import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) @@ -119,6 +120,56 @@ spec = describe "Parser" $ do | FRAGMENT_SPREAD |] + it "parses two minimal directive definitions" $ + let directive nm loc = + TypeSystemDefinition + (DirectiveDefinition + (Description Nothing) + nm + (ArgumentsDefinition []) + (loc :| [])) + example1 = + directive "example1" + (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition) + (Location {line = 2, column = 17}) + example2 = + directive "example2" + (DirLoc.ExecutableDirectiveLocation DirLoc.Field) + (Location {line = 3, column = 17}) + testSchemaExtension = example1 :| [ example2 ] + query = [r| + directive @example1 on FIELD_DEFINITION + directive @example2 on FIELD + |] + in parse document "" query `shouldParse` testSchemaExtension + + it "parses a directive definition with a default empty list argument" $ + let directive nm loc args = + TypeSystemDefinition + (DirectiveDefinition + (Description Nothing) + nm + (ArgumentsDefinition + [ InputValueDefinition + (Description Nothing) + argName + argType + argValue + [] + | (argName, argType, argValue) <- args]) + (loc :| [])) + defn = + directive "test" + (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition) + [("foo", + TypeList (TypeNamed "String"), + Just + $ Node (ConstList []) + $ Location {line = 1, column = 33})] + (Location {line = 1, column = 1}) + query = [r|directive @test(foo: [String] = []) on FIELD_DEFINITION|] + in parse document "" query `shouldParse` (defn :| [ ]) + it "parses schema extension with a new directive" $ parse document "" `shouldSucceedOn`[r| extend schema @newDirective diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs index 38d7d3a..f64e70a 100644 --- a/tests/Language/GraphQL/ErrorSpec.hs +++ b/tests/Language/GraphQL/ErrorSpec.hs @@ -8,17 +8,29 @@ module Language.GraphQL.ErrorSpec ) where import qualified Data.Aeson as Aeson -import qualified Data.Sequence as Seq +import Data.List.NonEmpty (NonEmpty (..)) import Language.GraphQL.Error -import Test.Hspec ( Spec - , describe - , it - , shouldBe - ) +import Test.Hspec + ( Spec + , describe + , it + , shouldBe + ) +import Text.Megaparsec (PosState(..)) +import Text.Megaparsec.Error (ParseError(..), ParseErrorBundle(..)) +import Text.Megaparsec.Pos (SourcePos(..), mkPos) spec :: Spec -spec = describe "singleError" $ - it "constructs an error with the given message" $ - let errors'' = Seq.singleton $ Error "Message." [] [] - expected = Response Aeson.Null errors'' - in singleError "Message." `shouldBe` expected +spec = describe "parseError" $ + it "generates response with a single error" $ do + let parseErrors = TrivialError 0 Nothing mempty :| [] + posState = PosState + { pstateInput = "" + , pstateOffset = 0 + , pstateSourcePos = SourcePos "" (mkPos 1) (mkPos 1) + , pstateTabWidth = mkPos 1 + , pstateLinePrefix = "" + } + Response Aeson.Null actual <- + parseError (ParseErrorBundle parseErrors posState) + length actual `shouldBe` 1 diff --git a/tests/Language/GraphQL/Execute/OrderedMapSpec.hs b/tests/Language/GraphQL/Execute/OrderedMapSpec.hs new file mode 100644 index 0000000..7c6a44f --- /dev/null +++ b/tests/Language/GraphQL/Execute/OrderedMapSpec.hs @@ -0,0 +1,72 @@ +{- This Source Code Form is subject to the terms of the Mozilla Public License, + 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 OverloadedStrings #-} + +module Language.GraphQL.Execute.OrderedMapSpec + ( spec + ) where + +import Language.GraphQL.Execute.OrderedMap (OrderedMap) +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +spec :: Spec +spec = + describe "OrderedMap" $ do + it "creates an empty map" $ + (mempty :: OrderedMap String) `shouldSatisfy` null + + it "creates a singleton" $ + let value :: String + value = "value" + in OrderedMap.size (OrderedMap.singleton "key" value) `shouldBe` 1 + + it "combines inserted vales" $ + let key = "key" + map1 = OrderedMap.singleton key ("1" :: String) + map2 = OrderedMap.singleton key ("2" :: String) + in OrderedMap.lookup key (map1 <> map2) `shouldBe` Just "12" + + it "shows the map" $ + let actual = show + $ OrderedMap.insert "key1" "1" + $ OrderedMap.singleton "key2" ("2" :: String) + expected = "fromList [(\"key2\",\"2\"),(\"key1\",\"1\")]" + in actual `shouldBe` expected + + it "traverses a map of just values" $ + let actual = sequence + $ OrderedMap.insert "key1" (Just "2") + $ OrderedMap.singleton "key2" $ Just ("1" :: String) + expected = Just + $ OrderedMap.insert "key1" "2" + $ OrderedMap.singleton "key2" ("1" :: String) + in actual `shouldBe` expected + + it "traverses a map with a Nothing" $ + let actual = sequence + $ OrderedMap.insert "key1" Nothing + $ OrderedMap.singleton "key2" $ Just ("1" :: String) + expected = Nothing + in actual `shouldBe` expected + + it "combines two maps preserving the order of the second one" $ + let map1 :: OrderedMap String + map1 = OrderedMap.insert "key2" "2" + $ OrderedMap.singleton "key1" "1" + map2 :: OrderedMap String + map2 = OrderedMap.insert "key4" "4" + $ OrderedMap.singleton "key3" "3" + expected = OrderedMap.insert "key4" "4" + $ OrderedMap.insert "key3" "3" + $ OrderedMap.insert "key2" "2" + $ OrderedMap.singleton "key1" "1" + in (map1 <> map2) `shouldBe` expected + + it "replaces existing values" $ + let key = "key" + actual = OrderedMap.replace key ("2" :: String) + $ OrderedMap.singleton key ("1" :: String) + in OrderedMap.lookup key actual `shouldBe` Just "2" diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index f6e3e6f..d14eb9d 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -8,34 +8,87 @@ module Language.GraphQL.ExecuteSpec ( spec ) where -import Control.Exception (SomeException) +import Control.Exception (Exception(..), SomeException) +import Control.Monad.Catch (throwM) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import Data.Aeson.Types (emptyObject) import Data.Conduit import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Language.GraphQL.AST (Document, Name) +import Data.Typeable (cast) +import Language.GraphQL.AST (Document, Location(..), Name) import Language.GraphQL.AST.Parser (document) import Language.GraphQL.Error -import Language.GraphQL.Execute -import Language.GraphQL.Type as Type -import Language.GraphQL.Type.Out as Out +import Language.GraphQL.Execute (execute) +import qualified Language.GraphQL.Type.Schema as Schema +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import Prelude hiding (id) import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse) import Text.RawString.QQ (r) +data PhilosopherException = PhilosopherException + deriving Show + +instance Exception PhilosopherException where + toException = toException. ResolverException + fromException e = do + ResolverException resolverException <- fromException e + cast resolverException + philosopherSchema :: Schema (Either SomeException) -philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty +philosopherSchema = + schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty + where + subscriptionRoot = Just subscriptionType + extraTypes = + [ Schema.ObjectType bookType + , Schema.ObjectType bookCollectionType + ] queryType :: Out.ObjectType (Either SomeException) queryType = Out.ObjectType "Query" Nothing [] - $ HashMap.singleton "philosopher" - $ ValueResolver philosopherField - $ pure $ Type.Object mempty + $ HashMap.fromList + [ ("philosopher", ValueResolver philosopherField philosopherResolver) + , ("genres", ValueResolver genresField genresResolver) + ] where philosopherField = - Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty + Out.Field Nothing (Out.NonNullObjectType philosopherType) + $ HashMap.singleton "id" + $ In.Argument Nothing (In.NamedScalarType id) Nothing + philosopherResolver = pure $ Object mempty + genresField = + let fieldType = Out.ListType $ Out.NonNullScalarType string + in Out.Field Nothing fieldType HashMap.empty + genresResolver :: Resolve (Either SomeException) + genresResolver = throwM PhilosopherException + +musicType :: Out.ObjectType (Either SomeException) +musicType = Out.ObjectType "Music" Nothing [] + $ HashMap.fromList resolvers + where + resolvers = + [ ("instrument", ValueResolver instrumentField instrumentResolver) + ] + instrumentResolver = pure $ String "piano" + instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + +poetryType :: Out.ObjectType (Either SomeException) +poetryType = Out.ObjectType "Poetry" Nothing [] + $ HashMap.fromList resolvers + where + resolvers = + [ ("genre", ValueResolver genreField genreResolver) + ] + genreResolver = pure $ String "Futurism" + genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + +interestType :: Out.UnionType (Either SomeException) +interestType = Out.UnionType "Interest" Nothing [musicType, poetryType] philosopherType :: Out.ObjectType (Either SomeException) philosopherType = Out.ObjectType "Philosopher" Nothing [] @@ -44,19 +97,68 @@ philosopherType = Out.ObjectType "Philosopher" Nothing [] resolvers = [ ("firstName", ValueResolver firstNameField firstNameResolver) , ("lastName", ValueResolver lastNameField lastNameResolver) + , ("school", ValueResolver schoolField schoolResolver) + , ("interest", ValueResolver interestField interestResolver) + , ("majorWork", ValueResolver majorWorkField majorWorkResolver) + , ("century", ValueResolver centuryField centuryResolver) ] firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty - firstNameResolver = pure $ Type.String "Friedrich" + firstNameResolver = pure $ String "Friedrich" lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty - lastNameResolver = pure $ Type.String "Nietzsche" + lastNameResolver = pure $ String "Nietzsche" + schoolField + = Out.Field Nothing (Out.NonNullEnumType schoolType) HashMap.empty + schoolResolver = pure $ Enum "EXISTENTIALISM" + interestField + = Out.Field Nothing (Out.NonNullUnionType interestType) HashMap.empty + interestResolver = pure + $ Object + $ HashMap.fromList [("instrument", "piano")] + majorWorkField + = Out.Field Nothing (Out.NonNullInterfaceType workType) HashMap.empty + majorWorkResolver = pure + $ Object + $ HashMap.fromList + [ ("title", "Also sprach Zarathustra: Ein Buch für Alle und Keinen") + ] + centuryField = + Out.Field Nothing (Out.NonNullScalarType int) HashMap.empty + centuryResolver = pure $ Float 18.5 + +workType :: Out.InterfaceType (Either SomeException) +workType = Out.InterfaceType "Work" Nothing [] + $ HashMap.fromList fields + where + fields = [("title", titleField)] + titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + +bookType :: Out.ObjectType (Either SomeException) +bookType = Out.ObjectType "Book" Nothing [workType] + $ HashMap.fromList resolvers + where + resolvers = + [ ("title", ValueResolver titleField titleResolver) + ] + titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + titleResolver = pure "Also sprach Zarathustra: Ein Buch für Alle und Keinen" + +bookCollectionType :: Out.ObjectType (Either SomeException) +bookCollectionType = Out.ObjectType "Book" Nothing [workType] + $ HashMap.fromList resolvers + where + resolvers = + [ ("title", ValueResolver titleField titleResolver) + ] + titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + titleResolver = pure "The Three Critiques" subscriptionType :: Out.ObjectType (Either SomeException) subscriptionType = Out.ObjectType "Subscription" Nothing [] $ HashMap.singleton "newQuote" - $ EventStreamResolver quoteField (pure $ Type.Object mempty) - $ pure $ yield $ Type.Object mempty + $ EventStreamResolver quoteField (pure $ Object mempty) + $ pure $ yield $ Object mempty where quoteField = Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty @@ -70,6 +172,13 @@ quoteType = Out.ObjectType "Quote" Nothing [] quoteField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty +schoolType :: EnumType +schoolType = EnumType "School" Nothing $ HashMap.fromList + [ ("NOMINALISM", EnumValue Nothing) + , ("REALISM", EnumValue Nothing) + , ("IDEALISM", EnumValue Nothing) + ] + type EitherStreamOrValue = Either (ResponseEventStream (Either SomeException) Aeson.Value) (Response Aeson.Value) @@ -118,6 +227,99 @@ spec = Right (Right actual) = either (pure . parseError) execute' $ parse document "" "{ philosopher { firstName } philosopher { lastName } }" in actual `shouldBe` expected + + it "errors on invalid output enum values" $ + let data'' = Aeson.object + [ "philosopher" .= Aeson.object + [ "school" .= Aeson.Null + ] + ] + executionErrors = pure $ Error + { message = "Enum value completion failed." + , locations = [Location 1 17] + , path = [] + } + expected = Response data'' executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ philosopher { school } }" + in actual `shouldBe` expected + + it "gives location information for non-null unions" $ + let data'' = Aeson.object + [ "philosopher" .= Aeson.object + [ "interest" .= Aeson.Null + ] + ] + executionErrors = pure $ Error + { message = "Union value completion failed." + , locations = [Location 1 17] + , path = [] + } + expected = Response data'' executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ philosopher { interest } }" + in actual `shouldBe` expected + + it "gives location information for invalid interfaces" $ + let data'' = Aeson.object + [ "philosopher" .= Aeson.object + [ "majorWork" .= Aeson.Null + ] + ] + executionErrors = pure $ Error + { message = "Interface value completion failed." + , locations = [Location 1 17] + , path = [] + } + expected = Response data'' executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ philosopher { majorWork { title } } }" + in actual `shouldBe` expected + + it "gives location information for invalid scalar arguments" $ + let data'' = Aeson.object + [ "philosopher" .= Aeson.Null + ] + executionErrors = pure $ Error + { message = "Argument coercing failed." + , locations = [Location 1 15] + , path = [] + } + expected = Response data'' executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ philosopher(id: true) { lastName } }" + in actual `shouldBe` expected + + it "gives location information for failed result coercion" $ + let data'' = Aeson.object + [ "philosopher" .= Aeson.object + [ "century" .= Aeson.Null + ] + ] + executionErrors = pure $ Error + { message = "Result coercion failed." + , locations = [Location 1 26] + , path = [] + } + expected = Response data'' executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ philosopher(id: \"1\") { century } }" + in actual `shouldBe` expected + + it "gives location information for failed result coercion" $ + let data'' = Aeson.object + [ "genres" .= Aeson.Null + ] + executionErrors = pure $ Error + { message = "PhilosopherException" + , locations = [Location 1 3] + , path = [] + } + expected = Response data'' executionErrors + Right (Right actual) = either (pure . parseError) execute' + $ parse document "" "{ genres }" + in actual `shouldBe` expected + context "Subscription" $ it "subscribes" $ let data'' = Aeson.object diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs index 6f90436..f75aef6 100644 --- a/tests/Language/GraphQL/Validate/RulesSpec.hs +++ b/tests/Language/GraphQL/Validate/RulesSpec.hs @@ -49,16 +49,18 @@ catType :: ObjectType IO catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList [ ("name", nameResolver) , ("nickname", nicknameResolver) - , ("doesKnowCommand", doesKnowCommandResolver) + , ("doesKnowCommands", doesKnowCommandsResolver) , ("meowVolume", meowVolumeResolver) ] where meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 3 - doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean) - $ HashMap.singleton "catCommand" - $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing - doesKnowCommandResolver = ValueResolver doesKnowCommandField + doesKnowCommandsType = In.NonNullListType + $ In.NonNullEnumType catCommandType + doesKnowCommandsField = Field Nothing (Out.NonNullScalarType boolean) + $ HashMap.singleton "catCommands" + $ In.Argument Nothing doesKnowCommandsType Nothing + doesKnowCommandsResolver = ValueResolver doesKnowCommandsField $ pure $ Boolean True nameResolver :: Resolver IO @@ -845,7 +847,7 @@ spec = } in validate queryString `shouldBe` [expected] - context "providedRequiredArgumentsRule" $ + context "providedRequiredArgumentsRule" $ do it "checks for (non-)nullable arguments" $ let queryString = [r| { @@ -866,17 +868,17 @@ spec = context "variablesInAllowedPositionRule" $ do it "rejects wrongly typed variable arguments" $ let queryString = [r| - query catCommandArgQuery($catCommandArg: CatCommand) { - cat { - doesKnowCommand(catCommand: $catCommandArg) + query dogCommandArgQuery($dogCommandArg: DogCommand) { + dog { + doesKnowCommand(dogCommand: $dogCommandArg) } } |] expected = Error { message = - "Variable \"$catCommandArg\" of type \ - \\"CatCommand\" used in position expecting type \ - \\"!CatCommand\"." + "Variable \"$dogCommandArg\" of type \ + \\"DogCommand\" used in position expecting type \ + \\"!DogCommand\"." , locations = [AST.Location 2 44] } in validate queryString `shouldBe` [expected] @@ -897,7 +899,7 @@ spec = } in validate queryString `shouldBe` [expected] - context "valuesOfCorrectTypeRule" $ + context "valuesOfCorrectTypeRule" $ do it "rejects values of incorrect types" $ let queryString = [r| { @@ -912,3 +914,49 @@ spec = , locations = [AST.Location 4 52] } in validate queryString `shouldBe` [expected] + + it "uses the location of a single list value" $ + let queryString = [r| + { + cat { + doesKnowCommands(catCommands: [3]) + } + } + |] + expected = Error + { message = + "Value 3 cannot be coerced to type \"!CatCommand\"." + , locations = [AST.Location 4 54] + } + in validate queryString `shouldBe` [expected] + + it "validates input object properties once" $ + let queryString = [r| + { + findDog(complex: { name: 3 }) { + name + } + } + |] + expected = Error + { message = + "Value 3 cannot be coerced to type \"!String\"." + , locations = [AST.Location 3 46] + } + in validate queryString `shouldBe` [expected] + + it "checks for required list members" $ + let queryString = [r| + { + cat { + doesKnowCommands(catCommands: [null]) + } + } + |] + expected = Error + { message = + "List of non-null values of type \"CatCommand\" \ + \cannot contain null values." + , locations = [AST.Location 4 54] + } + in validate queryString `shouldBe` [expected] |