diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,8 +6,60 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [Unreleased] +## [0.8.0.0] - 2020-06-20 +### Fixed +- The parser rejects variables when parsing defaultValue (DefaultValue). The + specification defines default values as `Value` with `const` parameter and + constants cannot be variables. `AST.Document.ConstValue` was added, + `AST.Document.ObjectField` was modified. +- AST transformation should never fail. + * Arguments and fields with a missing variable as value should be left out. + * Invalid (recusrive or non-existing) fragments should be skipped. +- Argument value coercion. +- Variable value coercion. +- Result coercion. +- The executor should skip the fields missing in the object type and not fail. +- Merging subselections. +### Changed +- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function + pair. +- `AST.Core.Value` was moved into `Type.Definition`. These values are used only + in the execution and type system, it is not a part of the parsing tree. +- `Type` module is superseded by `Type.Out`. This module contains now only + exports from other module that complete `Type.In` and `Type.Out` exports. +- `Error.CollectErrsT` contains the new `Resolution` data structure. + `Resolution` represents the state used by the executor. It contains all types + defined in the schema and collects the thrown errors. + +### Added +- `Type.Definition` contains base type system definition, e.g. Enums and + Scalars. +- `Type.Schema` describes a schema. Both public functions that execute queries + accept a `Schema` now instead of a `HashMap`. The execution fails if the root + operation doesn't match the root Query type in the schema. +- `Type.In` and `Type.Out` contain definitions for input and output types. +- `Execute.Coerce` defines a typeclass responsible for input, variable value + coercion. It decouples us a bit from JSON since any format can be used to pass + query variables. Execution functions accept (`HashMap Name a`) instead of + `Subs`, where a is an instance of `VariableValue`. + +### Removed +- `Schema.scalar`, `Schema.wrappedScalar`. They accepted everything can be + converted to JSON and JSON is not suitable as an internal representation for + GraphQL. E.g. GraphQL distinguishes between Floats and Integers. +- `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no + need in special functions to construct field resolvers anymore, resolvers are + normal functions attached to the fields in the schema representation. +- `Schema.resolve` is superseded by `Execute.Execution`. +- `Error.runAppendErrs` isn't used anywhere. +- `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias` + `TypeCondition` were modified, moved into `Execute.Transform.Document` and + made private. These types describe intermediate representation used by the + executor internally. Moving was required to avoid cyclic dependencies between + the executor and type system. +- `AST.Core` doesn't reexports anything. + ## [0.7.0.0] - 2020-05-11 ### Fixed - Result of null encoding @@ -20,7 +72,7 @@ - `Trans.argument`. - Schema extension parser. - Contributing guidelines. -- `Schema.resolversToMap` (intended for to be used internally). +- `Schema.resolversToMap` (intended to be used internally). ### Changed - Rename `AST.Definition` into `AST.Document.ExecutableDefinition`. @@ -215,7 +267,7 @@ ### Added - Data types for the GraphQL language. -[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD +[0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0 [0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0 [0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0 [0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -17,14 +17,15 @@ > import Control.Monad.IO.Class (liftIO) > import Data.Aeson (encode) > import Data.ByteString.Lazy.Char8 (putStrLn) -> import Data.HashMap.Strict (HashMap) > import qualified Data.HashMap.Strict as HashMap -> import Data.List.NonEmpty (NonEmpty(..)) > import Data.Text (Text) +> import qualified Data.Text as Text > import Data.Time (getCurrentTime) > > import Language.GraphQL -> import qualified Language.GraphQL.Schema as Schema +> import Language.GraphQL.Trans +> import Language.GraphQL.Type +> import qualified Language.GraphQL.Type.Out as Out > > import Prelude hiding (putStrLn) @@ -35,11 +36,19 @@ First we build a GraphQL schema. -> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO)) -> schema1 = HashMap.singleton "Query" $ hello :| [] +> schema1 :: Schema IO +> schema1 = Schema queryType Nothing > -> hello :: Schema.Resolver IO -> hello = Schema.scalar "hello" (return ("it's me" :: Text)) +> queryType :: ObjectType IO +> queryType = ObjectType "Query" Nothing [] +> $ HashMap.singleton "hello" +> $ Out.Resolver helloField hello +> +> helloField :: Field IO +> helloField = Field Nothing (Out.NamedScalarType string) mempty +> +> hello :: ActionT IO Value +> hello = pure $ String "it's me" This defines a simple schema with one type and one field, that resolves to a fixed value. @@ -52,7 +61,7 @@ To run the query, we call the `graphql` with the schema and the query. > main1 :: IO () -> main1 = putStrLn =<< encode <$> graphql schema1 query1 +> main1 = graphql schema1 query1 >>= putStrLn . encode This runs the query by fetching the one field defined, returning @@ -65,13 +74,21 @@ For this example, we're going to be using time. -> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO)) -> schema2 = HashMap.singleton "Query" $ time :| [] +> schema2 :: Schema IO +> schema2 = Schema queryType2 Nothing > -> time :: Schema.Resolver IO -> time = Schema.scalar "time" $ do +> queryType2 :: ObjectType IO +> queryType2 = ObjectType "Query" Nothing [] +> $ HashMap.singleton "time" +> $ Out.Resolver timeField time +> +> timeField :: Field IO +> timeField = Field Nothing (Out.NamedScalarType string) mempty +> +> time :: ActionT IO Value +> time = do > t <- liftIO getCurrentTime -> return $ show t +> pure $ String $ Text.pack $ show t This defines a simple schema with one type and one field, which resolves to the current time. @@ -82,7 +99,7 @@ > query2 = "{ time }" > > main2 :: IO () -> main2 = putStrLn =<< encode <$> graphql schema2 query2 +> main2 = graphql schema2 query2 >>= putStrLn . encode This runs the query, returning the current time @@ -124,14 +141,20 @@ Now that we have two resolvers, we can define a schema which uses them both. -> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO)) -> schema3 = HashMap.singleton "Query" $ hello :| [time] +> schema3 :: Schema IO +> schema3 = Schema queryType3 Nothing > +> queryType3 :: ObjectType IO +> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList +> [ ("hello", Out.Resolver helloField hello) +> , ("time", Out.Resolver timeField time) +> ] +> > query3 :: Text > query3 = "query timeAndHello { time hello }" > > main3 :: IO () -> main3 = putStrLn =<< encode <$> graphql schema3 query3 +> main3 = graphql schema3 query3 >>= putStrLn . encode This queries for both time and hello, returning diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/graphql.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: graphql -version: 0.7.0.0 +version: 0.8.0.0 license: BSD3 license-file: LICENSE copyright: (c) 2019-2020 Eugen Wissner, @@ -41,13 +41,18 @@ Language.GraphQL.AST.Parser Language.GraphQL.Error Language.GraphQL.Execute - Language.GraphQL.Schema + Language.GraphQL.Execute.Coerce Language.GraphQL.Trans Language.GraphQL.Type + Language.GraphQL.Type.In + Language.GraphQL.Type.Out hs-source-dirs: src other-modules: + Language.GraphQL.Execute.Execution Language.GraphQL.Execute.Transform + Language.GraphQL.Type.Definition Language.GraphQL.Type.Directive + Language.GraphQL.Type.Schema default-language: Haskell2010 build-depends: aeson >=1.4.7.1 && <1.5, @@ -55,9 +60,11 @@ containers >=0.6.2.1 && <0.7, megaparsec >=8.0.0 && <8.1, parser-combinators >=1.2.1 && <1.3, + scientific >=0.3.6.2 && <0.4, text >=1.2.4.0 && <1.3, transformers >=0.5.6.2 && <0.6, - unordered-containers >=0.2.10.0 && <0.3 + unordered-containers >=0.2.10.0 && <0.3, + vector >=0.12.1.2 && <0.13 test-suite tasty type: exitcode-stdio-1.0 @@ -68,9 +75,13 @@ Language.GraphQL.AST.LexerSpec Language.GraphQL.AST.ParserSpec Language.GraphQL.ErrorSpec + Language.GraphQL.Execute.CoerceSpec + Language.GraphQL.ExecuteSpec + Language.GraphQL.Type.OutSpec Test.DirectiveSpec Test.FragmentSpec Test.KitchenSinkSpec + Test.RootOperationSpec Test.StarWars.Data Test.StarWars.QuerySpec Test.StarWars.Schema @@ -89,6 +100,8 @@ megaparsec >=8.0.0 && <8.1, parser-combinators >=1.2.1 && <1.3, raw-strings-qq ==1.1.*, + scientific >=0.3.6.2 && <0.4, text >=1.2.4.0 && <1.3, transformers >=0.5.6.2 && <0.6, - unordered-containers >=0.2.10.0 && <0.3 + unordered-containers >=0.2.10.0 && <0.3, + vector >=0.12.1.2 && <0.13 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -5,29 +5,30 @@ ) where import qualified Data.Aeson as Aeson -import Data.List.NonEmpty (NonEmpty) import Data.HashMap.Strict (HashMap) import Data.Text (Text) +import Language.GraphQL.AST.Document +import Language.GraphQL.AST.Parser import Language.GraphQL.Error import Language.GraphQL.Execute -import Language.GraphQL.AST.Parser -import qualified Language.GraphQL.Schema as Schema +import Language.GraphQL.Execute.Coerce +import Language.GraphQL.Type.Schema import Text.Megaparsec (parse) -- | If the text parses correctly as a @GraphQL@ query the query is --- executed using the given 'Schema.Resolver's. +-- executed using the given 'Schema'. graphql :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. + => Schema m -- ^ Resolvers. -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. -graphql = flip graphqlSubs mempty +graphql = flip graphqlSubs (mempty :: Aeson.Object) -- | If the text parses correctly as a @GraphQL@ query the substitution is -- applied to the query and the query is then executed using to the given --- 'Schema.Resolver's. -graphqlSubs :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. - -> Schema.Subs -- ^ Variable substitution function. +-- 'Schema'. +graphqlSubs :: (Monad m, VariableValue a) + => Schema m -- ^ Resolvers. + -> HashMap Name a -- ^ Variable substitution function. -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. graphqlSubs schema f diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -1,41 +1,11 @@ -- | This is the AST meant to be executed. module Language.GraphQL.AST.Core - ( Alias - , Arguments(..) - , Directive(..) - , Document - , Field(..) - , Fragment(..) - , Name - , Operation(..) - , Selection(..) - , TypeCondition - , Value(..) + ( Arguments(..) ) where -import Data.Int (Int32) import Data.HashMap.Strict (HashMap) -import Data.List.NonEmpty (NonEmpty) -import Data.Sequence (Seq) -import Data.String (IsString(..)) -import Data.Text (Text) -import Language.GraphQL.AST (Alias, Name, TypeCondition) - --- | GraphQL document is a non-empty list of operations. -type Document = NonEmpty Operation - --- | GraphQL has 3 operation types: queries, mutations and subscribtions. --- --- Currently only queries and mutations are supported. -data Operation - = Query (Maybe Text) (Seq Selection) - | Mutation (Maybe Text) (Seq Selection) - deriving (Eq, Show) - --- | Single GraphQL field. -data Field - = Field (Maybe Alias) Name Arguments (Seq Selection) - deriving (Eq, Show) +import Language.GraphQL.AST (Name) +import Language.GraphQL.Type.Definition -- | Argument list. newtype Arguments = Arguments (HashMap Name Value) @@ -47,32 +17,3 @@ instance Monoid Arguments where mempty = Arguments mempty --- | Directive. -data Directive = Directive Name Arguments - deriving (Eq, Show) - --- | Represents fragments and inline fragments. -data Fragment - = Fragment TypeCondition (Seq Selection) - deriving (Eq, Show) - --- | Single selection element. -data Selection - = SelectionFragment Fragment - | SelectionField Field - deriving (Eq, Show) - --- | Represents accordingly typed GraphQL values. -data Value - = Int Int32 - | Float Double -- ^ GraphQL Float is double precision - | String Text - | Boolean Bool - | Null - | Enum Name - | List [Value] - | Object (HashMap Name Value) - deriving (Eq, Show) - -instance IsString Value where - fromString = String . fromString diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -8,6 +8,7 @@ ( Alias , Argument(..) , ArgumentsDefinition(..) + , ConstValue(..) , Definition(..) , Description(..) , Directive(..) @@ -197,7 +198,7 @@ -- ** Input Values --- | Input value. +-- | Input value (literal or variable). data Value = Variable Name | Int Int32 @@ -207,18 +208,46 @@ | Null | Enum Name | List [Value] - | Object [ObjectField] + | Object [ObjectField Value] deriving (Eq, Show) +-- | Constant input value. +data ConstValue + = ConstInt Int32 + | ConstFloat Double + | ConstString Text + | ConstBoolean Bool + | ConstNull + | ConstEnum Name + | ConstList [ConstValue] + | ConstObject [ObjectField ConstValue] + deriving (Eq, Show) + -- | Key-value pair. -- --- A list of 'ObjectField's represents a GraphQL object type. -data ObjectField = ObjectField Name Value deriving (Eq, Show) +-- A list of 'ObjectField's represents a GraphQL object type. +data ObjectField a = ObjectField Name a + deriving (Eq, Show) -- ** Variables -- | Variable definition. -data VariableDefinition = VariableDefinition Name Type (Maybe Value) +-- +-- Each operation can include a list of variables: +-- +-- @ +-- 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 +-- 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 +-- itself. They make queries reusable. +data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue) deriving (Eq, Show) -- ** Type References @@ -445,7 +474,7 @@ -- -- The input type "Point2D" contains two value definitions: "x" and "y". data InputValueDefinition - = InputValueDefinition Description Name Type (Maybe Value) [Directive] + = InputValueDefinition Description Name Type (Maybe ConstValue) [Directive] deriving (Eq, Show) -- ** Unions diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -24,7 +24,6 @@ import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) -import qualified Language.GraphQL.AST as Full import Language.GraphQL.AST.Document -- | Instructs the encoder whether the GraphQL document should be minified or @@ -53,32 +52,32 @@ executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc executableDefinition _ acc = acc --- | Converts a t'Full.ExecutableDefinition' into a string. +-- | Converts a t'ExecutableDefinition' into a string. definition :: Formatter -> ExecutableDefinition -> Lazy.Text definition formatter x | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' | Minified <- formatter = encodeDefinition x where - encodeDefinition (Full.DefinitionOperation operation) + encodeDefinition (DefinitionOperation operation) = operationDefinition formatter operation - encodeDefinition (Full.DefinitionFragment fragment) + encodeDefinition (DefinitionFragment fragment) = fragmentDefinition formatter fragment --- | Converts a 'Full.OperationDefinition into a string. -operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text -operationDefinition formatter (Full.SelectionSet sels) +-- | Converts a 'OperationDefinition into a string. +operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text +operationDefinition formatter (SelectionSet sels) = selectionSet formatter sels -operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels) +operationDefinition formatter (OperationDefinition Query name vars dirs sels) = "query " <> node formatter name vars dirs sels -operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels) +operationDefinition formatter (OperationDefinition Mutation name vars dirs sels) = "mutation " <> node formatter name vars dirs sels --- | Converts a Full.Query or Full.Mutation into a string. +-- | Converts a Query or Mutation into a string. node :: Formatter -> - Maybe Full.Name -> - [Full.VariableDefinition] -> - [Full.Directive] -> - Full.SelectionSet -> + Maybe Name -> + [VariableDefinition] -> + [Directive] -> + SelectionSet -> Lazy.Text node formatter name vars dirs sels = Lazy.Text.fromStrict (fold name) @@ -87,31 +86,31 @@ <> eitherFormat formatter " " mempty <> selectionSet formatter sels -variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text +variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text variableDefinitions formatter = parensCommas formatter $ variableDefinition formatter -variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text -variableDefinition formatter (Full.VariableDefinition var ty dv) +variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text +variableDefinition formatter (VariableDefinition var ty defaultValue') = variable var <> eitherFormat formatter ": " ":" <> type' ty - <> maybe mempty (defaultValue formatter) dv + <> maybe mempty (defaultValue formatter) defaultValue' -defaultValue :: Formatter -> Full.Value -> Lazy.Text +defaultValue :: Formatter -> ConstValue -> Lazy.Text defaultValue formatter val = eitherFormat formatter " = " "=" - <> value formatter val + <> value formatter (fromConstValue val) -variable :: Full.Name -> Lazy.Text +variable :: Name -> Lazy.Text variable var = "$" <> Lazy.Text.fromStrict var -selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text +selectionSet :: Formatter -> SelectionSet -> Lazy.Text selectionSet formatter = bracesList formatter (selection formatter) . NonEmpty.toList -selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text +selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text selectionSetOpt formatter = bracesList formatter $ selection formatter indentSymbol :: Lazy.Text @@ -120,14 +119,14 @@ indent :: (Integral a) => a -> Lazy.Text indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol -selection :: Formatter -> Full.Selection -> Lazy.Text +selection :: Formatter -> Selection -> Lazy.Text selection formatter = Lazy.Text.append indent' . encodeSelection where - encodeSelection (Full.Field alias name args directives' selections) = + encodeSelection (Field alias name args directives' selections) = field incrementIndent alias name args directives' selections - encodeSelection (Full.InlineFragment typeCondition directives' selections) = + encodeSelection (InlineFragment typeCondition directives' selections) = inlineFragment incrementIndent typeCondition directives' selections - encodeSelection (Full.FragmentSpread name directives') = + encodeSelection (FragmentSpread name directives') = fragmentSpread incrementIndent name directives' incrementIndent | Pretty indentation <- formatter = Pretty $ indentation + 1 @@ -139,13 +138,13 @@ colon :: Formatter -> Lazy.Text colon formatter = eitherFormat formatter ": " ":" --- | Converts Full.Field into a string +-- | Converts Field into a string field :: Formatter -> - Maybe Full.Name -> - Full.Name -> - [Full.Argument] -> - [Full.Directive] -> - [Full.Selection] -> + Maybe Name -> + Name -> + [Argument] -> + [Directive] -> + [Selection] -> Lazy.Text field formatter alias name args dirs set = optempty prependAlias (fold alias) @@ -158,27 +157,27 @@ selectionSetOpt' = (eitherFormat formatter " " "" <>) . selectionSetOpt formatter -arguments :: Formatter -> [Full.Argument] -> Lazy.Text +arguments :: Formatter -> [Argument] -> Lazy.Text arguments formatter = parensCommas formatter $ argument formatter -argument :: Formatter -> Full.Argument -> Lazy.Text -argument formatter (Full.Argument name value') +argument :: Formatter -> Argument -> Lazy.Text +argument formatter (Argument name value') = Lazy.Text.fromStrict name <> colon formatter <> value formatter value' -- * Fragments -fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text +fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text fragmentSpread formatter name directives' = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) directives' inlineFragment :: Formatter -> - Maybe Full.TypeCondition -> - [Full.Directive] -> - Full.SelectionSet -> + Maybe TypeCondition -> + [Directive] -> + SelectionSet -> Lazy.Text inlineFragment formatter tc dirs sels = "... on " <> Lazy.Text.fromStrict (fold tc) @@ -186,8 +185,8 @@ <> eitherFormat formatter " " mempty <> selectionSet formatter sels -fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text -fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels) +fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text +fragmentDefinition formatter (FragmentDefinition name tc dirs sels) = "fragment " <> Lazy.Text.fromStrict name <> " on " <> Lazy.Text.fromStrict tc <> optempty (directives formatter) dirs @@ -196,27 +195,40 @@ -- * Miscellaneous --- | Converts a 'Full.Directive' into a string. -directive :: Formatter -> Full.Directive -> Lazy.Text -directive formatter (Full.Directive name args) +-- | Converts a 'Directive' into a string. +directive :: Formatter -> Directive -> Lazy.Text +directive formatter (Directive name args) = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args -directives :: Formatter -> [Full.Directive] -> Lazy.Text +directives :: Formatter -> [Directive] -> Lazy.Text directives Minified = spaces (directive Minified) directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter) --- | Converts a 'Full.Value' into a string. -value :: Formatter -> Full.Value -> Lazy.Text -value _ (Full.Variable x) = variable x -value _ (Full.Int x) = Builder.toLazyText $ decimal x -value _ (Full.Float x) = Builder.toLazyText $ realFloat x -value _ (Full.Boolean x) = booleanValue x -value _ Full.Null = "null" -value formatter (Full.String string) = stringValue formatter string -value _ (Full.Enum x) = Lazy.Text.fromStrict x -value formatter (Full.List x) = listValue formatter x -value formatter (Full.Object x) = objectValue formatter x +-- | Converts a 'Value' into a string. +value :: Formatter -> Value -> Lazy.Text +value _ (Variable x) = variable x +value _ (Int x) = Builder.toLazyText $ decimal x +value _ (Float x) = Builder.toLazyText $ realFloat x +value _ (Boolean x) = booleanValue x +value _ Null = "null" +value formatter (String string) = stringValue formatter string +value _ (Enum x) = Lazy.Text.fromStrict x +value formatter (List x) = listValue formatter x +value formatter (Object x) = objectValue formatter x +fromConstValue :: ConstValue -> Value +fromConstValue (ConstInt x) = Int x +fromConstValue (ConstFloat x) = Float x +fromConstValue (ConstBoolean x) = Boolean x +fromConstValue ConstNull = Null +fromConstValue (ConstString string) = String string +fromConstValue (ConstEnum x) = Enum x +fromConstValue (ConstList x) = List $ fromConstValue <$> x +fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x + where + fromConstObjectField (ObjectField key value') = + ObjectField key $ fromConstValue value' + booleanValue :: Bool -> Lazy.Text booleanValue True = "true" booleanValue False = "false" @@ -271,10 +283,10 @@ where unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord) -listValue :: Formatter -> [Full.Value] -> Lazy.Text +listValue :: Formatter -> [Value] -> Lazy.Text listValue formatter = bracketsCommas formatter $ value formatter -objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text +objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text objectValue formatter = intercalate $ objectField formatter where intercalate f @@ -282,22 +294,22 @@ . Lazy.Text.intercalate (eitherFormat formatter ", " ",") . fmap f -objectField :: Formatter -> Full.ObjectField -> Lazy.Text -objectField formatter (Full.ObjectField name value') = +objectField :: Formatter -> ObjectField Value -> Lazy.Text +objectField formatter (ObjectField name value') = Lazy.Text.fromStrict name <> colon formatter <> value formatter value' --- | Converts a 'Full.Type' a type into a string. -type' :: Full.Type -> Lazy.Text -type' (Full.TypeNamed x) = Lazy.Text.fromStrict x -type' (Full.TypeList x) = listType x -type' (Full.TypeNonNull x) = nonNullType x +-- | Converts a 'Type' a type into a string. +type' :: Type -> Lazy.Text +type' (TypeNamed x) = Lazy.Text.fromStrict x +type' (TypeList x) = listType x +type' (TypeNonNull x) = nonNullType x -listType :: Full.Type -> Lazy.Text +listType :: Type -> Lazy.Text listType x = brackets (type' x) -nonNullType :: Full.NonNullType -> Lazy.Text -nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!" -nonNullType (Full.NonNullTypeList x) = listType x <> "!" +nonNullType :: NonNullType -> Lazy.Text +nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!" +nonNullType (NonNullTypeList x) = listType x <> "!" -- * Internal diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -403,32 +403,38 @@ value :: Parser Value value = Variable <$> variable - <|> Float <$> try float - <|> Int <$> integer - <|> Boolean <$> booleanValue - <|> Null <$ symbol "null" - <|> String <$> blockString - <|> String <$> string - <|> Enum <$> try enumValue - <|> List <$> listValue - <|> Object <$> objectValue + <|> Float <$> try float + <|> Int <$> integer + <|> Boolean <$> booleanValue + <|> Null <$ symbol "null" + <|> String <$> blockString + <|> String <$> string + <|> Enum <$> try enumValue + <|> List <$> brackets (some value) + <|> Object <$> braces (some $ objectField value) "value error!" - where - booleanValue :: Parser Bool - booleanValue = True <$ symbol "true" - <|> False <$ symbol "false" - listValue :: Parser [Value] - listValue = brackets $ some value +constValue :: Parser ConstValue +constValue = ConstFloat <$> try float + <|> ConstInt <$> integer + <|> ConstBoolean <$> booleanValue + <|> ConstNull <$ symbol "null" + <|> ConstString <$> blockString + <|> ConstString <$> string + <|> ConstEnum <$> try enumValue + <|> ConstList <$> brackets (some constValue) + <|> ConstObject <$> braces (some $ objectField constValue) + "value error!" - objectValue :: Parser [ObjectField] - objectValue = braces $ some objectField +booleanValue :: Parser Bool +booleanValue = True <$ symbol "true" + <|> False <$ symbol "false" enumValue :: Parser Name enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name -objectField :: Parser ObjectField -objectField = ObjectField <$> name <* colon <*> value +objectField :: Parser a -> Parser (ObjectField a) +objectField valueParser = ObjectField <$> name <* colon <*> valueParser -- * Variables @@ -446,8 +452,8 @@ variable :: Parser Name variable = dollar *> name -defaultValue :: Parser (Maybe Value) -defaultValue = optional (equals *> value) "DefaultValue" +defaultValue :: Parser (Maybe ConstValue) +defaultValue = optional (equals *> constValue) "DefaultValue" -- * Input Types diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -5,21 +5,20 @@ module Language.GraphQL.Error ( parseError , CollectErrsT + , Resolution(..) , addErr , addErrMsg , runCollectErrs - , runAppendErrs , singleError ) where +import Control.Monad.Trans.State (StateT, modify, runStateT) import qualified Data.Aeson as Aeson +import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Data.Void (Void) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State ( StateT - , modify - , runStateT - ) +import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.Type.Schema import Text.Megaparsec ( ParseErrorBundle(..) , PosState(..) @@ -30,6 +29,12 @@ , unPos ) +-- | Executor context. +data Resolution m = Resolution + { errors :: [Aeson.Value] + , types :: HashMap Name (Type m) + } + -- | Wraps a parse error into a list of errors. parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value parseError ParseErrorBundle{..} = @@ -46,11 +51,13 @@ in (errorObject x sourcePosition : result, newState) -- | A wrapper to pass error messages around. -type CollectErrsT m = StateT [Aeson.Value] m +type CollectErrsT m = StateT (Resolution m) m -- | Adds an error to the list of errors. addErr :: Monad m => Aeson.Value -> CollectErrsT m () -addErr v = modify (v :) +addErr v = modify appender + where + appender resolution@Resolution{..} = resolution{ errors = v : errors } makeErrorMessage :: Text -> Aeson.Value makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)] @@ -66,23 +73,17 @@ addErrMsg :: Monad m => Text -> CollectErrsT m () addErrMsg = addErr . makeErrorMessage --- | Appends the given list of errors to the current list of errors. -appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m () -appendErrs errs = modify (errs ++) - -- | Runs the given query computation, but collects the errors into an error -- list, which is then sent back with the data. -runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value -runCollectErrs res = do - (dat, errs) <- runStateT res [] - if null errs +runCollectErrs :: Monad m + => HashMap Name (Type m) + -> CollectErrsT m Aeson.Value + -> m Aeson.Value +runCollectErrs types' res = do + (dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' } + if null errors then return $ Aeson.object [("data", dat)] - else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)] - --- | Runs the given computation, collecting the errors and appending them --- to the previous list of errors. -runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a -runAppendErrs f = do - (v, errs) <- lift $ runStateT f [] - appendErrs errs - return v + else return $ Aeson.object + [ ("data", dat) + , ("errors", Aeson.toJSON $ reverse errors) + ] diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute ( execute @@ -7,33 +5,30 @@ ) where import qualified Data.Aeson as Aeson -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Sequence (Seq(..)) import Data.Text (Text) -import qualified Data.Text as Text -import Language.GraphQL.AST.Document -import qualified Language.GraphQL.AST.Core as AST.Core +import Language.GraphQL.AST.Document (Document, Name) +import Language.GraphQL.Execute.Coerce +import Language.GraphQL.Execute.Execution import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error -import qualified Language.GraphQL.Schema as Schema +import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Schema -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. -execute :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. - -> Schema.Subs -- ^ Variable substitution function. +execute :: (Monad m, VariableValue a) + => Schema m -- ^ Resolvers. + -> HashMap.HashMap Name a -- ^ Variable substitution function. -> Document -- @GraphQL@ document. -> m Aeson.Value -execute schema subs doc = - maybe transformError (document schema Nothing) - $ Transform.document subs doc - where - transformError = return $ singleError "Schema transformation error." +execute schema = executeRequest schema Nothing -- | 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 @@ -41,46 +36,36 @@ -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. -executeWithName :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers +executeWithName :: (Monad m, VariableValue a) + => Schema m -- ^ Resolvers -> Text -- ^ Operation name. - -> Schema.Subs -- ^ Variable substitution function. + -> HashMap.HashMap Name a -- ^ Variable substitution function. -> Document -- ^ @GraphQL@ Document. -> m Aeson.Value -executeWithName schema name subs doc = - maybe transformError (document schema $ Just name) - $ Transform.document subs doc - where - transformError = return $ singleError "Schema transformation error." +executeWithName schema operationName = + executeRequest schema (Just operationName) -document :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) +executeRequest :: (Monad m, VariableValue a) + => Schema m -> Maybe Text - -> AST.Core.Document + -> HashMap.HashMap Name a + -> Document -> m Aeson.Value -document schema Nothing (op :| []) = operation schema op -document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of - [] -> return $ singleError - $ Text.unwords ["Operation", name, "couldn't be found in the document."] - (op:_) -> operation schema op - where - matchingName (AST.Core.Query (Just name') _) = name == name' - matchingName (AST.Core.Mutation (Just name') _) = name == name' - matchingName _ = False -document _ _ _ = return $ singleError "Missing operation name." +executeRequest schema operationName subs document = + case Transform.document schema operationName subs document of + Left queryError -> pure $ singleError $ Transform.queryError queryError + Right (Transform.Document types' rootObjectType operation) + | (Transform.Query _ fields) <- operation -> + executeOperation types' rootObjectType fields + | (Transform.Mutation _ fields) <- operation -> + executeOperation types' rootObjectType fields -operation :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) - -> AST.Core.Operation +-- This is actually executeMutation, but we don't distinguish between queries +-- and mutations yet. +executeOperation :: Monad m + => HashMap Name (Type m) + -> Out.ObjectType m + -> Seq (Transform.Selection m) -> m Aeson.Value -operation schema = schemaOperation - where - runResolver fields = runCollectErrs - . flip Schema.resolve fields - . Schema.resolversToMap - resolve fields queryType = maybe lookupError (runResolver fields) - $ HashMap.lookup queryType schema - lookupError = pure - $ singleError "Root operation type couldn't be found in the schema." - schemaOperation (AST.Core.Query _ fields) = resolve fields "Query" - schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation" +executeOperation types' objectType fields = + runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Types and functions used for input and result coercion. +module Language.GraphQL.Execute.Coerce + ( Output(..) + , Serialize(..) + , VariableValue(..) + , coerceInputLiteral + , matchFieldValues + ) where + +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 +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 qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out + +-- | Since variables are passed separately from the query, in an independent +-- format, they should be first coerced to the internal representation used by +-- this implementation. +class VariableValue a where + -- | Only a basic, format-specific, coercion must be done here. Type + -- correctness or nullability shouldn't be validated here, they will be + -- validated later. The type information is provided only as a hint. + -- + -- For example @GraphQL@ prohibits the coercion from a 't:Float' to an + -- 't:Int', but @JSON@ doesn't have integers, so whole numbers should be + -- coerced to 't:Int` when receiving variables as a JSON object. The same + -- holds for 't:Enum'. There are formats that support enumerations, @JSON@ + -- doesn't, so the type information is given and 'coerceVariableValue' can + -- check that an 't:Enum' is expected and treat the given value + -- appropriately. Even checking whether this value is a proper member of the + -- corresponding 't:Enum' type isn't required here, since this can be + -- checked independently. + -- + -- Another example is an @ID@. @GraphQL@ explicitly allows to coerce + -- integers and strings to @ID@s, so if an @ID@ is received as an integer, + -- it can be left as is and will be coerced later. + -- + -- If a value cannot be coerced without losing information, 'Nothing' should + -- be returned, the coercion will fail then and the query won't be executed. + coerceVariableValue + :: In.Type -- ^ Expected type (variable type given in the query). + -> a -- ^ Variable value being coerced. + -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise. + +instance VariableValue Aeson.Value where + coerceVariableValue _ Aeson.Null = Just Type.Null + coerceVariableValue (In.ScalarBaseType scalarType) value + | (Aeson.String stringValue) <- value = Just $ Type.String stringValue + | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue + | (Aeson.Number numberValue) <- value + , (Type.ScalarType "Float" _) <- scalarType = + Just $ Type.Float $ toRealFloat numberValue + | (Aeson.Number numberValue) <- value = -- ID or Int + Type.Int <$> toBoundedInteger numberValue + coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) = + Just $ Type.Enum stringValue + coerceVariableValue (In.InputObjectBaseType objectType) value + | (Aeson.Object objectValue) <- value = do + let (In.InputObjectType _ _ inputFields) = objectType + (newObjectValue, resultMap) <- foldWithKey objectValue inputFields + if HashMap.null newObjectValue + then Just $ Type.Object resultMap + else Nothing + where + foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues' + $ Just (objectValue, HashMap.empty) + matchFieldValues' _ _ Nothing = Nothing + matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) = + let (In.InputField _ fieldType _) = inputField + insert = flip (HashMap.insert fieldName) resultMap + newObjectValue = HashMap.delete fieldName objectValue + in case HashMap.lookup fieldName objectValue of + Just variableValue -> do + coerced <- coerceVariableValue fieldType variableValue + pure (newObjectValue, insert coerced) + Nothing -> Just (objectValue, resultMap) + coerceVariableValue (In.ListBaseType listType) value + | (Aeson.Array arrayValue) <- value = + Type.List <$> foldr foldVector (Just []) arrayValue + | otherwise = coerceVariableValue listType value + where + foldVector _ Nothing = Nothing + foldVector variableValue (Just list) = do + coerced <- coerceVariableValue listType variableValue + pure $ coerced : list + coerceVariableValue _ _ = Nothing + +-- | Looks up a value by name in the given map, coerces it and inserts into the +-- result map. If the coercion fails, returns 'Nothing'. If the value isn't +-- given, but a default value is known, inserts the default value into the +-- result map. Otherwise it fails with 'Nothing' if the Input Type is a +-- Non-Nullable type, or returns the unchanged, original map. +matchFieldValues :: forall a + . (In.Type -> a -> Maybe Type.Value) + -> HashMap Name a + -> Name + -> In.Type + -> Maybe Type.Value + -> Maybe (HashMap Name Type.Value) + -> Maybe (HashMap Name Type.Value) +matchFieldValues coerce values' fieldName type' defaultValue resultMap = + case HashMap.lookup fieldName values' of + Just variableValue -> coerceRuntimeValue $ coerce type' variableValue + Nothing + | Just value <- defaultValue -> + HashMap.insert fieldName value <$> resultMap + | Nothing <- defaultValue + , In.isNonNullType type' -> Nothing + | otherwise -> resultMap + where + coerceRuntimeValue (Just Type.Null) + | In.isNonNullType type' = Nothing + coerceRuntimeValue coercedValue = + HashMap.insert fieldName <$> coercedValue <*> resultMap + +-- | Coerces operation arguments according to the input coercion rules for the +-- corresponding types. +coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value +coerceInputLiteral (In.isNonNullType -> False) Type.Null = Just Type.Null +coerceInputLiteral (In.ScalarBaseType type') value + | (Type.String stringValue) <- value + , (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue + | (Type.Boolean booleanValue) <- value + , (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue + | (Type.Int intValue) <- value + , (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue + | (Type.Float floatValue) <- value + , (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue + | (Type.Int intValue) <- value + , (Type.ScalarType "Float" _) <- type' = + Just $ Type.Float $ fromIntegral intValue + | (Type.String stringValue) <- value + , (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue + | (Type.Int intValue) <- value + , (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue + where + decimal = Type.String + . Text.Lazy.toStrict + . Text.Builder.toLazyText + . Text.Builder.decimal +coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue) + | member enumValue type' = Just $ Type.Enum enumValue + where + member value (Type.EnumType _ _ members) = HashMap.member value members +coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = + let (In.InputObjectType _ _ inputFields) = type' + in Type.Object + <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields + where + matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) = + matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue +coerceInputLiteral (In.ListBaseType listType) (Type.List list) = + Type.List <$> traverse (coerceInputLiteral listType) list +coerceInputLiteral (In.ListBaseType listType) singleton = + wrapSingleton listType singleton + where + wrapSingleton (In.ListBaseType listType') singleton' = + Type.List <$> sequence [wrapSingleton listType' singleton'] + wrapSingleton listType' singleton' = + Type.List <$> sequence [coerceInputLiteral listType' singleton'] +coerceInputLiteral _ _ = Nothing + +-- | 'Serialize' describes how a @GraphQL@ value should be serialized. +class Serialize a where + -- | Serializes a @GraphQL@ value according to the given serialization + -- format. + -- + -- Type infomration is given as a hint, e.g. if you need to know what type + -- is being serialized to serialize it properly. Don't do any validation for + -- @GraphQL@ built-in types here. + -- + -- If the value cannot be serialized without losing information, return + -- 'Nothing' — it will cause a field error. + serialize :: forall m + . Out.Type m -- ^ Expected output type. + -> Output a -- ^ The value to be serialized. + -> Maybe a -- ^ Serialized value on success or 'Nothing'. + -- | __null__ representation in the given serialization format. + null :: a + +-- | Intermediate type used to serialize a @GraphQL@ value. +-- +-- The serialization is done during the execution, and 'Output' contains +-- already serialized data (in 'List' and 'Object') as well as the new layer +-- that has to be serialized in the current step. So 'Output' is parameterized +-- by the serialization format. +data Output a + = Int Int32 + | Float Double + | String Text + | Boolean Bool + | Enum Name + | List [a] + | Object (Map Name a) + deriving (Eq, Show) + +instance forall a. IsString (Output a) where + fromString = String . fromString + +instance Serialize Aeson.Value where + serialize (Out.ScalarBaseType scalarType) value + | Type.ScalarType "Int" _ <- scalarType + , Int int <- value = Just $ Aeson.toJSON int + | Type.ScalarType "Float" _ <- scalarType + , Float float <- value = Just $ Aeson.toJSON float + | Type.ScalarType "String" _ <- scalarType + , String string <- value = Just $ Aeson.String string + | Type.ScalarType "ID" _ <- scalarType + , String string <- value = Just $ Aeson.String string + | Type.ScalarType "Boolean" _ <- scalarType + , 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 _ _ = Nothing + null = Aeson.Null diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Language.GraphQL.Execute.Execution + ( executeSelectionSet + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.State (gets) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map.Strict (Map) +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 Data.Text (Text) +import Language.GraphQL.AST (Name) +import Language.GraphQL.AST.Core +import Language.GraphQL.Error +import Language.GraphQL.Execute.Coerce +import qualified Language.GraphQL.Execute.Transform as Transform +import Language.GraphQL.Trans +import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Schema +import Prelude hiding (null) + +resolveFieldValue :: Monad m + => Type.Value + -> Type.Subs + -> ActionT m a + -> m (Either Text a) +resolveFieldValue result args = + flip runReaderT (Context {arguments = Arguments args, values = result}) + . runExceptT + . runActionT + +collectFields :: Monad m + => Out.ObjectType m + -> Seq (Transform.Selection m) + -> Map Name (NonEmpty (Transform.Field m)) +collectFields objectType = foldl forEach Map.empty + where + forEach groupedFields (Transform.SelectionField field) = + let responseKey = aliasOrName field + in Map.insertWith (<>) responseKey (field :| []) groupedFields + forEach groupedFields (Transform.SelectionFragment selectionFragment) + | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment + , doesFragmentTypeApply fragmentType objectType = + let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet + in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet + | otherwise = groupedFields + +aliasOrName :: forall m. Transform.Field m -> Name +aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias + +resolveAbstractType :: Monad m + => AbstractType m + -> Type.Subs + -> CollectErrsT m (Maybe (Out.ObjectType m)) +resolveAbstractType abstractType values' + | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do + types' <- gets types + case HashMap.lookup typeName types' of + Just (ObjectType objectType) -> + if instanceOf objectType abstractType + then pure $ Just objectType + else pure Nothing + _ -> pure Nothing + | otherwise = pure Nothing + +doesFragmentTypeApply :: forall m + . CompositeType m + -> Out.ObjectType m + -> Bool +doesFragmentTypeApply (CompositeObjectType fragmentType) objectType = + fragmentType == objectType +doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType = + instanceOf objectType $ AbstractInterfaceType fragmentType +doesFragmentTypeApply (CompositeUnionType fragmentType) objectType = + instanceOf objectType $ AbstractUnionType fragmentType + +instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool +instanceOf objectType (AbstractInterfaceType interfaceType) = + let Out.ObjectType _ _ interfaces _ = objectType + in foldr go False interfaces + where + go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc = + acc || foldr go (interfaceType == objectInterfaceType) interfaces +instanceOf objectType (AbstractUnionType unionType) = + let Out.UnionType _ _ members = unionType + in foldr go False members + where + go unionMemberType acc = acc || objectType == unionMemberType + +executeField :: (Monad m, Serialize a) + => Out.Resolver m + -> Type.Value + -> NonEmpty (Transform.Field m) + -> CollectErrsT m a +executeField (Out.Resolver fieldDefinition resolver) prev fields = do + let Out.Field _ fieldType argumentDefinitions = fieldDefinition + let (Transform.Field _ _ arguments' _ :| []) = fields + case coerceArgumentValues argumentDefinitions arguments' of + Nothing -> errmsg "Argument coercing failed." + Just argumentValues -> do + answer <- lift $ resolveFieldValue prev argumentValues resolver + case answer of + Right result -> completeValue fieldType fields result + Left errorMessage -> errmsg errorMessage + +completeValue :: (Monad m, Serialize a) + => Out.Type m + -> NonEmpty (Transform.Field m) + -> Type.Value + -> CollectErrsT m 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) = + let Type.EnumType _ _ enumMembers = enumType + in if HashMap.member enum enumMembers + then coerceResult outputType $ Enum enum + else errmsg "Value completion failed." +completeValue (Out.ObjectBaseType objectType) fields result = + executeSelectionSet result objectType $ mergeSelectionSets fields +completeValue (Out.InterfaceBaseType interfaceType) fields result + | Type.Object objectMap <- result = do + let abstractType = AbstractInterfaceType interfaceType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType -> executeSelectionSet result objectType + $ mergeSelectionSets fields + Nothing -> errmsg "Value completion failed." +completeValue (Out.UnionBaseType unionType) fields result + | Type.Object objectMap <- result = do + let abstractType = AbstractUnionType unionType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of + Just objectType -> executeSelectionSet result objectType + $ mergeSelectionSets fields + Nothing -> errmsg "Value completion failed." +completeValue _ _ _ = errmsg "Value completion failed." + +mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m) +mergeSelectionSets = foldr forEach mempty + where + forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet = + selectionSet <> fieldSelectionSet + +errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a +errmsg errorMessage = addErrMsg errorMessage >> pure null + +coerceResult :: (Monad m, Serialize a) + => Out.Type m + -> Output a + -> CollectErrsT m a +coerceResult outputType result + | Just serialized <- serialize outputType result = pure serialized + | otherwise = errmsg "Result coercion failed." + +-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies +-- each field to each 'Transform.Selection'. Resolves into a value containing +-- the resolved 'Transform.Selection', or a null value and error information. +executeSelectionSet :: (Monad m, Serialize a) + => Type.Value + -> Out.ObjectType m + -> Seq (Transform.Selection m) + -> CollectErrsT m a +executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do + let fields = collectFields objectType selectionSet + resolvedValues <- Map.traverseMaybeWithKey forEach fields + coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues + where + 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.foldrWithKey forEach (pure mempty) argumentDefinitions + where + forEach variableName (In.Argument _ variableType defaultValue) = + matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue + coerceArgumentValue inputType (Transform.Int integer) = + coerceInputLiteral inputType (Type.Int integer) + coerceArgumentValue inputType (Transform.Boolean boolean) = + coerceInputLiteral inputType (Type.Boolean boolean) + coerceArgumentValue inputType (Transform.String string) = + coerceInputLiteral inputType (Type.String string) + coerceArgumentValue inputType (Transform.Float float) = + coerceInputLiteral inputType (Type.Float float) + coerceArgumentValue inputType (Transform.Enum enum) = + coerceInputLiteral inputType (Type.Enum enum) + coerceArgumentValue inputType Transform.Null + | In.isNonNullType inputType = Nothing + | otherwise = coerceInputLiteral inputType Type.Null + coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) = + let coerceItem = coerceInputLiteral inputType + in Type.List <$> traverse coerceItem list + coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object) + | In.InputObjectType _ _ inputFields <- inputType = + let go = forEachField object + resultMap = HashMap.foldrWithKey go (pure mempty) inputFields + in Type.Object <$> resultMap + coerceArgumentValue _ (Transform.Variable variable) = pure variable + coerceArgumentValue _ _ = Nothing + forEachField object variableName (In.InputField _ variableType defaultValue) = + matchFieldValues coerceArgumentValue object variableName variableType defaultValue diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -1,125 +1,356 @@ {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} --- | After the document is parsed, before getting executed the AST is --- transformed into a similar, simpler AST. This module is responsible for --- this transformation. +-- | After the document is parsed, before getting executed, the AST is +-- transformed into a similar, simpler AST. Performed transformations include: +-- +-- * Replacing variables with their values. +-- * Inlining fragments. Some fragments can be completely eliminated and +-- replaced by the selection set they represent. Invalid (recursive and +-- non-existing) fragments are skipped. The most fragments are inlined, so the +-- executor doesn't have to perform additional lookups later. +-- * Evaluating directives (@\@include@ and @\@skip@). +-- +-- This module is also responsible for smaller rewrites that touch only parts of +-- the original AST. module Language.GraphQL.Execute.Transform - ( document + ( Document(..) + , Field(..) + , Fragment(..) + , Input(..) + , Operation(..) + , QueryError(..) + , Selection(..) + , document + , queryError ) where -import Control.Arrow (first) import Control.Monad (foldM, unless) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) -import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) +import Control.Monad.Trans.State (State, evalStateT, gets, modify) +import Data.Foldable (find) +import Data.Functor.Identity (Identity(..)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int32) +import Data.Maybe (fromMaybe) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Sequence (Seq, (<|), (><)) +import Data.Text (Text) +import qualified Data.Text as Text import qualified Language.GraphQL.AST as Full -import qualified Language.GraphQL.AST.Core as Core -import Language.GraphQL.AST.Document (Definition(..), Document) -import qualified Language.GraphQL.Schema as Schema +import Language.GraphQL.AST (Name) +import Language.GraphQL.AST.Core +import qualified Language.GraphQL.Execute.Coerce as Coerce +import Language.GraphQL.Type.Directive (Directive(..)) import qualified Language.GraphQL.Type.Directive as Directive +import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Schema --- | Associates a fragment name with a list of 'Core.Field's. -data Replacement = Replacement - { fragments :: HashMap Core.Name Core.Fragment - , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition +-- | Associates a fragment name with a list of 'Field's. +data Replacement m = Replacement + { fragments :: HashMap Full.Name (Fragment m) + , fragmentDefinitions :: FragmentDefinitions + , variableValues :: Type.Subs + , types :: HashMap Full.Name (Type m) } -type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a +type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition -liftJust :: forall a. a -> TransformT a -liftJust = lift . lift . Just +-- | Represents fragments and inline fragments. +data Fragment m + = Fragment (CompositeType m) (Seq (Selection m)) +-- | Single selection element. +data Selection m + = SelectionFragment (Fragment 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)) + +-- | Single GraphQL field. +data Field m = Field + (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m)) + +-- | Contains the operation to be executed along with its root type. +data Document m = Document + (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m) + +data OperationDefinition = OperationDefinition + Full.OperationType + (Maybe Full.Name) + [Full.VariableDefinition] + [Full.Directive] + Full.SelectionSet + +-- | Query error types. +data QueryError + = OperationNotFound Text + | OperationNameRequired + | CoercionError + | TransformationError + | EmptyDocument + | UnsupportedRootOperation + +data Input + = Int Int32 + | Float Double + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Type.Value] + | Object (HashMap Name 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 + -> Either QueryError OperationDefinition +getOperation Nothing (operation' :| []) = pure operation' +getOperation Nothing _ = Left OperationNameRequired +getOperation (Just operationName) operations + | Just operation' <- find matchingName operations = pure operation' + | otherwise = Left $ OperationNotFound operationName + where + matchingName (OperationDefinition _ name _ _ _) = + name == Just operationName + +lookupInputType + :: Full.Type + -> HashMap.HashMap Full.Name (Type m) + -> Maybe In.Type +lookupInputType (Full.TypeNamed name) types = + case HashMap.lookup name types of + Just (ScalarType scalarType) -> + Just $ In.NamedScalarType scalarType + Just (EnumType enumType) -> + Just $ In.NamedEnumType enumType + Just (InputObjectType objectType) -> + Just $ In.NamedInputObjectType objectType + _ -> Nothing +lookupInputType (Full.TypeList list) types + = In.ListType + <$> lookupInputType list types +lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types = + case HashMap.lookup nonNull types of + Just (ScalarType scalarType) -> + Just $ In.NonNullScalarType scalarType + Just (EnumType enumType) -> + Just $ In.NonNullEnumType enumType + Just (InputObjectType objectType) -> + Just $ In.NonNullInputObjectType objectType + _ -> Nothing +lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types + = In.NonNullListType + <$> lookupInputType nonNull types + +coerceVariableValues :: Coerce.VariableValue a + => forall m + . HashMap Full.Name (Type m) + -> OperationDefinition + -> HashMap.HashMap Full.Name a + -> Either QueryError Type.Subs +coerceVariableValues types operationDefinition variableValues = + let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition + in maybe (Left CoercionError) Right + $ foldr forEach (Just HashMap.empty) variableDefinitions + where + forEach variableDefinition coercedValues = do + let Full.VariableDefinition variableName variableTypeName defaultValue = + variableDefinition + let defaultValue' = constValue <$> defaultValue + variableType <- lookupInputType variableTypeName types + + Coerce.matchFieldValues + coerceVariableValue' + variableValues + variableName + variableType + defaultValue' + coercedValues + coerceVariableValue' variableType value' + = Coerce.coerceVariableValue variableType value' + >>= Coerce.coerceInputLiteral variableType + +constValue :: Full.ConstValue -> Type.Value +constValue (Full.ConstInt i) = Type.Int i +constValue (Full.ConstFloat f) = Type.Float f +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.ConstObject o) = + Type.Object $ HashMap.fromList $ constObjectField <$> o + where + constObjectField (Full.ObjectField key value') = (key, constValue value') + -- | Rewrites the original syntax tree into an intermediate representation used -- for query execution. -document :: Schema.Subs -> Document -> Maybe Core.Document -document subs document' = - flip runReaderT subs - $ evalStateT (collectFragments >> operations operationDefinitions) - $ Replacement HashMap.empty fragmentTable +document :: Coerce.VariableValue a + => forall m + . Schema m + -> Maybe Full.Name + -> HashMap Full.Name a + -> Full.Document + -> Either QueryError (Document m) +document schema operationName subs ast = do + let referencedTypes = collectReferencedTypes schema + + (operations, fragmentTable) <- defragment ast + chosenOperation <- getOperation operationName operations + coercedValues <- coerceVariableValues referencedTypes chosenOperation subs + + let replacement = Replacement + { fragments = HashMap.empty + , fragmentDefinitions = fragmentTable + , variableValues = coercedValues + , types = referencedTypes + } + case chosenOperation of + OperationDefinition Full.Query _ _ _ _ -> + pure $ Document referencedTypes (query schema) + $ operation chosenOperation replacement + OperationDefinition Full.Mutation _ _ _ _ + | Just mutationType <- mutation schema -> + pure $ Document referencedTypes mutationType + $ operation chosenOperation replacement + _ -> Left UnsupportedRootOperation + +defragment + :: Full.Document + -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions) +defragment ast = + let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast + nonEmptyOperations = NonEmpty.nonEmpty operations + emptyDocument = Left EmptyDocument + in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations where - (fragmentTable, operationDefinitions) = foldr defragment mempty document' - defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc = - (definition :) <$> acc - defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc = - let (Full.FragmentDefinition name _ _ _) = definition - in first (HashMap.insert name definition) acc - defragment _ acc = acc + defragment' definition (operations, fragments') + | (Full.ExecutableDefinition executable) <- definition + , (Full.DefinitionOperation operation') <- executable = + (transform operation' : operations, fragments') + | (Full.ExecutableDefinition executable) <- definition + , (Full.DefinitionFragment fragment) <- executable + , (Full.FragmentDefinition name _ _ _) <- fragment = + (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 -- * Operation -operations :: [Full.OperationDefinition] -> TransformT Core.Document -operations operations' = do - coreOperations <- traverse operation operations' - lift . lift $ NonEmpty.nonEmpty coreOperations - -operation :: Full.OperationDefinition -> TransformT Core.Operation -operation (Full.SelectionSet sels) - = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels -operation (Full.OperationDefinition Full.Query name _vars _dirs sels) - = Core.Query name <$> appendSelection sels -operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) - = Core.Mutation name <$> appendSelection sels +operation :: OperationDefinition -> Replacement m -> Operation m +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 -- * Selection -selection :: - Full.Selection -> - TransformT (Either (Seq Core.Selection) Core.Selection) +selection + :: Full.Selection + -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) selection (Full.Field alias name arguments' directives' selections) = - maybe (Left mempty) (Right . Core.SelectionField) <$> do - fieldArguments <- arguments arguments' + maybe (Left mempty) (Right . SelectionField) <$> do + fieldArguments <- foldM go HashMap.empty arguments' fieldSelections <- appendSelection selections fieldDirectives <- Directive.selection <$> directives directives' - let field' = Core.Field alias name fieldArguments fieldSelections + let field' = Field alias name fieldArguments fieldSelections pure $ field' <$ fieldDirectives + where + go arguments (Full.Argument name' value') = + inputField arguments name' value' + selection (Full.FragmentSpread name directives') = - maybe (Left mempty) (Right . Core.SelectionFragment) <$> do + maybe (Left mempty) (Right . SelectionFragment) <$> do spreadDirectives <- Directive.selection <$> directives directives' fragments' <- gets fragments - fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments') - pure $ fragment <$ spreadDirectives - where - lookupDefinition = do + fragmentDefinitions' <- gets fragmentDefinitions - found <- lift . lift $ HashMap.lookup name fragmentDefinitions' - fragmentDefinition found + case HashMap.lookup name fragments' of + Just definition -> lift $ pure $ definition <$ spreadDirectives + Nothing + | Just definition <- HashMap.lookup name fragmentDefinitions' -> do + fragDef <- fragmentDefinition definition + case fragDef of + Just fragment -> lift $ pure $ fragment <$ spreadDirectives + _ -> lift $ pure Nothing + | otherwise -> lift $ pure Nothing selection (Full.InlineFragment type' directives' selections) = do fragmentDirectives <- Directive.selection <$> directives directives' case fragmentDirectives of Nothing -> pure $ Left mempty _ -> do fragmentSelectionSet <- appendSelection selections - pure $ maybe Left selectionFragment type' fragmentSelectionSet + + case type' of + Nothing -> pure $ Left fragmentSelectionSet + Just typeName -> do + typeCondition' <- lookupTypeCondition typeName + case typeCondition' of + Just typeCondition -> pure $ + selectionFragment typeCondition fragmentSelectionSet + Nothing -> pure $ Left mempty where selectionFragment typeName = Right - . Core.SelectionFragment - . Core.Fragment typeName + . SelectionFragment + . Fragment typeName -appendSelection :: - Traversable t => - t Full.Selection -> - TransformT (Seq Core.Selection) +appendSelection :: Traversable t + => t Full.Selection + -> State (Replacement m) (Seq (Selection m)) appendSelection = foldM go mempty where go acc sel = append acc <$> selection sel append acc (Left list) = list >< acc append acc (Right one) = one <| acc -directives :: [Full.Directive] -> TransformT [Core.Directive] +directives :: [Full.Directive] -> State (Replacement m) [Directive] directives = traverse directive where - directive (Full.Directive directiveName directiveArguments) = - Core.Directive directiveName <$> arguments directiveArguments + directive (Full.Directive directiveName directiveArguments) + = Directive directiveName . Arguments + <$> foldM go HashMap.empty directiveArguments + go arguments (Full.Argument name value') = do + substitutedValue <- value value' + return $ HashMap.insert name substitutedValue arguments -- * Fragment replacement -- | Extract fragment definitions into a single 'HashMap'. -collectFragments :: TransformT () +collectFragments :: State (Replacement m) () collectFragments = do fragDefs <- gets fragmentDefinitions let nextValue = head $ HashMap.elems fragDefs @@ -127,41 +358,79 @@ _ <- fragmentDefinition nextValue collectFragments -fragmentDefinition :: - Full.FragmentDefinition -> - TransformT Core.Fragment +lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m)) +lookupTypeCondition type' = do + types' <- gets types + case HashMap.lookup type' types' of + Just (ObjectType objectType) -> + lift $ pure $ Just $ CompositeObjectType objectType + Just (UnionType unionType) -> + lift $ pure $ Just $ CompositeUnionType unionType + Just (InterfaceType interfaceType) -> + lift $ pure $ Just $ CompositeInterfaceType interfaceType + _ -> lift $ pure Nothing + +fragmentDefinition + :: Full.FragmentDefinition + -> State (Replacement m) (Maybe (Fragment m)) fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do modify deleteFragmentDefinition fragmentSelection <- appendSelection selections - let newValue = Core.Fragment type' fragmentSelection - modify $ insertFragment newValue - liftJust newValue + compositeType <- lookupTypeCondition type' + + case compositeType of + Just compositeType' -> do + let newValue = Fragment compositeType' fragmentSelection + modify $ insertFragment newValue + lift $ pure $ Just newValue + _ -> lift $ pure Nothing where - deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') = - Replacement fragments' $ HashMap.delete name fragmentDefinitions' - insertFragment newValue (Replacement fragments' fragmentDefinitions') = - let newFragments = HashMap.insert name newValue fragments' - in Replacement newFragments fragmentDefinitions' + deleteFragmentDefinition replacement@Replacement{..} = + let newDefinitions = HashMap.delete name fragmentDefinitions + in replacement{ fragmentDefinitions = newDefinitions } + insertFragment newValue replacement@Replacement{..} = + let newFragments = HashMap.insert name newValue fragments + in replacement{ fragments = newFragments } -arguments :: [Full.Argument] -> TransformT Core.Arguments -arguments = fmap Core.Arguments . foldM go HashMap.empty +value :: forall m. Full.Value -> State (Replacement m) Type.Value +value (Full.Variable name) = + gets (fromMaybe Type.Null . HashMap.lookup name . variableValues) +value (Full.Int int) = pure $ Type.Int int +value (Full.Float float) = pure $ Type.Float float +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.Object object) = + Type.Object . HashMap.fromList <$> traverse objectField object where - go arguments' (Full.Argument name value') = do - substitutedValue <- value value' - return $ HashMap.insert name substitutedValue arguments' + objectField (Full.ObjectField name value') = (name,) <$> value value' -value :: Full.Value -> TransformT Core.Value -value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift -value (Full.Int i) = pure $ Core.Int i -value (Full.Float f) = pure $ Core.Float f -value (Full.String x) = pure $ Core.String x -value (Full.Boolean b) = pure $ Core.Boolean b -value Full.Null = pure Core.Null -value (Full.Enum e) = pure $ Core.Enum e -value (Full.List l) = - Core.List <$> traverse value l -value (Full.Object o) = - Core.Object . HashMap.fromList <$> traverse objectField o +input :: forall m. Full.Value -> State (Replacement m) (Maybe Input) +input (Full.Variable name) = + gets (fmap Variable . HashMap.lookup name . variableValues) +input (Full.Int int) = pure $ pure $ Int int +input (Full.Float float) = pure $ pure $ Float float +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.Object object) = do + objectFields <- foldM objectField HashMap.empty object + pure $ pure $ Object objectFields + where + objectField resultMap (Full.ObjectField name value') = + inputField resultMap name value' -objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value) -objectField (Full.ObjectField name value') = (name,) <$> value value' +inputField :: forall m + . HashMap Full.Name Input + -> Full.Name + -> Full.Value + -> State (Replacement m) (HashMap Full.Name Input) +inputField resultMap name value' = do + objectFieldValue <- input value' + case objectFieldValue of + Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap + Nothing -> pure resultMap diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs deleted file mode 100644 --- a/src/Language/GraphQL/Schema.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | This module provides a representation of a @GraphQL@ Schema in addition to --- functions for defining and manipulating schemas. -module Language.GraphQL.Schema - ( Resolver(..) - , Subs - , object - , resolve - , resolversToMap - , scalar - , wrappedObject - , wrappedScalar - -- * AST Reexports - , Field - , Value(..) - ) where - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Reader (runReaderT) -import Data.Foldable (fold, toList) -import Data.Maybe (fromMaybe) -import qualified Data.Aeson as Aeson -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Sequence (Seq) -import Data.Text (Text) -import qualified Data.Text as T -import Language.GraphQL.AST.Core -import Language.GraphQL.Error -import Language.GraphQL.Trans -import qualified Language.GraphQL.Type as Type - --- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error --- information (if an error has occurred). @m@ is an arbitrary monad, usually --- 'IO'. -data Resolver m = Resolver - Text -- ^ Name - (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver - --- | Converts resolvers to a map. -resolversToMap - :: (Foldable f, Functor f) - => f (Resolver m) - -> HashMap Text (Field -> CollectErrsT m Aeson.Object) -resolversToMap = HashMap.fromList . toList . fmap toKV - where - toKV (Resolver name f) = (name, f) - --- | Contains variables for the query. The key of the map is a variable name, --- and the value is the variable value. -type Subs = HashMap Name Value - --- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m -object name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld@(Field _ _ _ flds) resolver - = withField (resolve (resolversToMap resolver) flds) fld - --- | Like 'object' but can be null or a list of objects. -wrappedObject :: - Monad m => - Name -> - ActionT m (Type.Wrapping [Resolver m]) -> - Resolver m -wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld@(Field _ _ _ sels) resolver - = withField (traverse (resolveMap sels) resolver) fld - resolveMap = flip (resolve . resolversToMap) - --- | A scalar represents a primitive value, like a string or an integer. -scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m -scalar name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld result = withField (return result) fld - --- | Like 'scalar' but can be null or a list of scalars. -wrappedScalar :: - (Monad m, Aeson.ToJSON a) => - Name -> - ActionT m (Type.Wrapping a) -> - Resolver m -wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld (Type.Named result) = withField (return result) fld - resolveRight fld Type.Null - = return $ HashMap.singleton (aliasOrName fld) Aeson.Null - resolveRight fld (Type.List result) = withField (return result) fld - -resolveFieldValue :: - Monad m => - ActionT m a -> - (Field -> a -> CollectErrsT m Aeson.Object) -> - Field -> - CollectErrsT m (HashMap Text Aeson.Value) -resolveFieldValue f resolveRight fld@(Field _ _ args _) = do - result <- lift $ reader . runExceptT . runActionT $ f - either resolveLeft (resolveRight fld) result - where - reader = flip runReaderT $ Context {arguments=args} - resolveLeft err = do - _ <- addErrMsg err - return $ HashMap.singleton (aliasOrName fld) Aeson.Null - --- | Helper function to facilitate error handling and result emitting. -withField :: (Monad m, Aeson.ToJSON a) - => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) -withField v fld - = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v - --- | Takes a list of 'Resolver's and a list of 'Field's and applies each --- 'Resolver' to each 'Field'. Resolves into a value containing the --- resolved 'Field', or a null value and error information. -resolve :: Monad m - => HashMap Text (Field -> CollectErrsT m Aeson.Object) - -> Seq Selection - -> CollectErrsT m Aeson.Value -resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers - where - resolveTypeName f = do - value <- f $ Field Nothing "__typename" mempty mempty - return $ HashMap.lookupDefault "" "__typename" value - tryResolvers (SelectionField fld@(Field _ name _ _)) - = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld - tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do - that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers - if maybe True (Aeson.String typeCondition ==) that - then fmap fold . traverse tryResolvers $ selections' - else return mempty - errmsg fld@(Field _ name _ _) = do - addErrMsg $ T.unwords ["field", name, "not resolved."] - return $ HashMap.singleton (aliasOrName fld) Aeson.Null - -aliasOrName :: Field -> Text -aliasOrName (Field alias name _ _) = fromMaybe name alias diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -1,8 +1,8 @@ -- | Monad transformer stack used by the @GraphQL@ resolvers. module Language.GraphQL.Trans - ( ActionT(..) + ( argument + , ActionT(..) , Context(..) - , argument ) where import Control.Applicative (Alternative(..)) @@ -14,12 +14,15 @@ import qualified Data.HashMap.Strict as HashMap import Data.Maybe (fromMaybe) import Data.Text (Text) +import Language.GraphQL.AST (Name) import Language.GraphQL.AST.Core +import Language.GraphQL.Type.Definition import Prelude hiding (lookup) -- | Resolution context holds resolver arguments. -newtype Context = Context +data Context = Context { arguments :: Arguments + , values :: Value } -- | Monad transformer stack used by the resolvers to provide error handling @@ -54,7 +57,7 @@ mplus = (<|>) -- | Retrieves an argument by its name. If the argument with this name couldn't --- be found, returns 'Value.Null' (i.e. the argument is assumed to +-- be found, returns 'Null' (i.e. the argument is assumed to -- be optional then). argument :: Monad m => Name -> ActionT m Value argument argumentName = do diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -1,55 +1,16 @@ --- | Definitions for @GraphQL@ input types. +-- | Reexports non-conflicting type system and schema definitions. module Language.GraphQL.Type - ( Wrapping(..) + ( In.InputField(..) + , In.InputObjectType(..) + , Out.Field(..) + , Out.InterfaceType(..) + , Out.ObjectType(..) + , Out.UnionType(..) + , module Language.GraphQL.Type.Definition + , module Language.GraphQL.Type.Schema ) where -import Data.Aeson as Aeson (ToJSON, toJSON) -import qualified Data.Aeson as Aeson - --- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping --- type can wrap other wrapping or named types. Wrapping types are lists and --- Non-Null types (named types are nullable by default). --- --- This 'Wrapping' type doesn\'t reflect this distinction exactly but it is --- used in the resolvers to take into account that the returned value can be --- nullable or an (arbitrary nested) list. -data Wrapping a - = List [Wrapping a] -- ^ Arbitrary nested list - | Named a -- ^ Named type without further wrapping - | Null -- ^ Null - deriving (Eq, Show) - -instance Functor Wrapping where - fmap f (List list) = List $ fmap (fmap f) list - fmap f (Named named) = Named $ f named - fmap _ Null = Null - -instance Foldable Wrapping where - foldr f acc (List list) = foldr (flip $ foldr f) acc list - foldr f acc (Named named) = f named acc - foldr _ acc Null = acc - -instance Traversable Wrapping where - traverse f (List list) = List <$> traverse (traverse f) list - traverse f (Named named) = Named <$> f named - traverse _ Null = pure Null - -instance Applicative Wrapping where - pure = Named - Null <*> _ = Null - _ <*> Null = Null - (Named f) <*> (Named x) = Named $ f x - (List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs - (Named f) <*> list = f <$> list - (List fs) <*> named = List $ (<*> named) <$> fs - -instance Monad Wrapping where - return = pure - Null >>= _ = Null - (Named x) >>= f = f x - (List xs) >>= f = List $ fmap (>>= f) xs - -instance ToJSON a => ToJSON (Wrapping a) where - toJSON (List list) = toJSON list - toJSON (Named named) = toJSON named - toJSON Null = Aeson.Null +import Language.GraphQL.Type.Definition +import Language.GraphQL.Type.Schema (Schema(..)) +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/Type/Definition.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Types that can be used as both input and output types. +module Language.GraphQL.Type.Definition + ( EnumType(..) + , EnumValue(..) + , ScalarType(..) + , Subs + , Value(..) + , boolean + , float + , id + , int + , string + ) where + +import Data.Int (Int32) +import Data.HashMap.Strict (HashMap) +import Data.String (IsString(..)) +import Data.Text (Text) +import Language.GraphQL.AST.Document (Name) +import Prelude hiding (id) + +-- | Represents accordingly typed GraphQL values. +data Value + = Int Int32 + | Float Double -- ^ GraphQL Float is double precision. + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Value] -- ^ Arbitrary nested list. + | Object (HashMap Name Value) + deriving (Eq, Show) + +instance IsString Value where + fromString = String . fromString + +-- | Contains variables for the query. The key of the map is a variable name, +-- and the value is the variable value. +type Subs = HashMap Name Value + +-- | Scalar type definition. +-- +-- The leaf values of any request and input values to arguments are Scalars (or +-- Enums) . +data ScalarType = ScalarType Name (Maybe Text) + +instance Eq ScalarType where + (ScalarType this _) == (ScalarType that _) = this == that + +-- | Enum type definition. +-- +-- Some leaf values of requests and input values are Enums. GraphQL serializes +-- Enum values as strings, however internally Enums can be represented by any +-- kind of type, often integers. +data EnumType = EnumType Name (Maybe Text) (HashMap Name EnumValue) + +instance Eq EnumType where + (EnumType this _ _) == (EnumType that _ _) = this == that + +-- | Enum value is a single member of an 'EnumType'. +newtype EnumValue = EnumValue (Maybe Text) + +-- | The @String@ scalar type represents textual data, represented as UTF-8 +-- character sequences. The String type is most often used by GraphQL to +-- represent free-form human-readable text. +string :: ScalarType +string = ScalarType "String" (Just description) + where + description = + "The `String` scalar type represents textual data, represented as \ + \UTF-8 character sequences. The String type is most often used by \ + \GraphQL to represent free-form human-readable text." + +-- | The @Boolean@ scalar type represents @true@ or @false@. +boolean :: ScalarType +boolean = ScalarType "Boolean" (Just description) + where + description = "The `Boolean` scalar type represents `true` or `false`." + +-- | The @Int@ scalar type represents non-fractional signed whole numeric +-- values. Int can represent values between \(-2^{31}\) and \(2^{31 - 1}\). +int :: ScalarType +int = ScalarType "Int" (Just description) + where + description = + "The `Int` scalar type represents non-fractional signed whole numeric \ + \values. Int can represent values between -(2^31) and 2^31 - 1." + +-- | The @Float@ scalar type represents signed double-precision fractional +-- values as specified by +-- [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point). +float :: ScalarType +float = ScalarType "Float" (Just description) + where + description = + "The `Float` scalar type represents signed double-precision fractional \ + \values as specified by \ + \[IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)." + +-- | The @ID@ scalar type represents a unique identifier, often used to refetch +-- an object or as key for a cache. The ID type appears in a JSON response as a +-- String; however, it is not intended to be human-readable. When expected as an +-- input type, any string (such as @"4"@) or integer (such as @4@) input value +-- will be accepted as an ID. +id :: ScalarType +id = ScalarType "ID" (Just description) + where + description = + "The `ID` scalar type represents a unique identifier, often used to \ + \refetch an object or as key for a cache. The ID type appears in a \ + \JSON response as a String; however, it is not intended to be \ + \human-readable. When expected as an input type, any string (such as \ + \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID." diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs --- a/src/Language/GraphQL/Type/Directive.hs +++ b/src/Language/GraphQL/Type/Directive.hs @@ -1,11 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} module Language.GraphQL.Type.Directive - ( selection + ( Directive(..) + , selection ) where import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL.AST (Name) import Language.GraphQL.AST.Core +import Language.GraphQL.Type.Definition + +-- | Directive. +data Directive = Directive Name Arguments + deriving (Eq, Show) -- | Directive processing status. data Status diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/Type/In.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Input types and values. +-- +-- This module is intended to be imported qualified, to avoid name clashes +-- with 'Language.GraphQL.Type.Out'. +module Language.GraphQL.Type.In + ( Argument(..) + , InputField(..) + , InputObjectType(..) + , Type(..) + , isNonNullType + , pattern EnumBaseType + , pattern ListBaseType + , pattern InputObjectBaseType + , pattern ScalarBaseType + ) where + +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.Type.Definition + +-- | Single field of an 'InputObjectType'. +data InputField = InputField (Maybe Text) Type (Maybe Value) + +-- | Input object type definition. +-- +-- An input object defines a structured collection of fields which may be +-- supplied to a field argument. +data InputObjectType = InputObjectType + Name (Maybe Text) (HashMap Name InputField) + +instance Eq InputObjectType where + (InputObjectType this _ _) == (InputObjectType that _ _) = this == that + +-- | These types may be used as input types for arguments and directives. +-- +-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping +-- type can wrap other wrapping or named types. Wrapping types are lists and +-- Non-Null types (named types are nullable by default). +data Type + = NamedScalarType ScalarType + | NamedEnumType EnumType + | NamedInputObjectType InputObjectType + | ListType Type + | NonNullScalarType ScalarType + | NonNullEnumType EnumType + | NonNullInputObjectType InputObjectType + | NonNullListType Type + deriving Eq + +-- | Field argument definition. +data Argument = Argument (Maybe Text) Type (Maybe Value) + +-- | Matches either 'NamedScalarType' or 'NonNullScalarType'. +pattern ScalarBaseType :: ScalarType -> Type +pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType) + +-- | Matches either 'NamedEnumType' or 'NonNullEnumType'. +pattern EnumBaseType :: EnumType -> Type +pattern EnumBaseType enumType <- (isEnumType -> Just enumType) + +-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'. +pattern InputObjectBaseType :: InputObjectType -> Type +pattern InputObjectBaseType objectType <- (isInputObjectType -> Just objectType) + +-- | Matches either 'ListType' or 'NonNullListType'. +pattern ListBaseType :: Type -> Type +pattern ListBaseType listType <- (isListType -> Just listType) + +{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-} + +isScalarType :: Type -> Maybe ScalarType +isScalarType (NamedScalarType inputType) = Just inputType +isScalarType (NonNullScalarType inputType) = Just inputType +isScalarType _ = Nothing + +isInputObjectType :: Type -> Maybe InputObjectType +isInputObjectType (NamedInputObjectType inputType) = Just inputType +isInputObjectType (NonNullInputObjectType inputType) = Just inputType +isInputObjectType _ = Nothing + +isEnumType :: Type -> Maybe EnumType +isEnumType (NamedEnumType inputType) = Just inputType +isEnumType (NonNullEnumType inputType) = Just inputType +isEnumType _ = Nothing + +isListType :: Type -> Maybe Type +isListType (ListType inputType) = Just inputType +isListType (NonNullListType inputType) = Just inputType +isListType _ = Nothing + +-- | Checks whether the given input type is a non-null type. +isNonNullType :: Type -> Bool +isNonNullType (NonNullScalarType _) = True +isNonNullType (NonNullEnumType _) = True +isNonNullType (NonNullInputObjectType _) = True +isNonNullType (NonNullListType _) = True +isNonNullType _ = False diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/Type/Out.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Output types and values. +-- +-- This module is intended to be imported qualified, to avoid name clashes +-- with 'Language.GraphQL.Type.In'. +module Language.GraphQL.Type.Out + ( Field(..) + , InterfaceType(..) + , ObjectType(..) + , Resolver(..) + , Type(..) + , UnionType(..) + , isNonNullType + , pattern EnumBaseType + , pattern InterfaceBaseType + , pattern ListBaseType + , pattern ObjectBaseType + , pattern ScalarBaseType + , pattern UnionBaseType + ) where + +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Language.GraphQL.AST (Name) +import Language.GraphQL.Trans +import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.In as In + +-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error +-- information (if an error has occurred). @m@ is an arbitrary monad, usually +-- 'IO'. +-- +-- Resolving a field can result in a leaf value or an object, which is +-- represented as a list of nested resolvers, used to resolve the fields of that +-- object. +data Resolver m = Resolver (Field m) (ActionT m Value) + +-- | Object type definition. +-- +-- Almost all of the GraphQL types you define will be object types. Object +-- types have a name, but most importantly describe their fields. +data ObjectType m = ObjectType + Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m)) + +instance forall a. Eq (ObjectType a) where + (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that + +-- | Interface Type Definition. +-- +-- When a field can return one of a heterogeneous set of types, a Interface type +-- is used to describe what types are possible, and what fields are in common +-- across all types. +data InterfaceType m = InterfaceType + Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m)) + +instance forall a. Eq (InterfaceType a) where + (InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that + +-- | Union Type Definition. +-- +-- When a field can return one of a heterogeneous set of types, a Union type is +-- used to describe what types are possible. +data UnionType m = UnionType Name (Maybe Text) [ObjectType m] + +instance forall a. Eq (UnionType a) where + (UnionType this _ _) == (UnionType that _ _) = this == that + +-- | Output object field definition. +data Field m = Field + (Maybe Text) -- ^ Description. + (Type m) -- ^ Field type. + (HashMap Name In.Argument) -- ^ Arguments. + +-- | These types may be used as output types as the result of fields. +-- +-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping +-- type can wrap other wrapping or named types. Wrapping types are lists and +-- Non-Null types (named types are nullable by default). +data Type m + = NamedScalarType ScalarType + | NamedEnumType EnumType + | NamedObjectType (ObjectType m) + | NamedInterfaceType (InterfaceType m) + | NamedUnionType (UnionType m) + | ListType (Type m) + | NonNullScalarType ScalarType + | NonNullEnumType EnumType + | NonNullObjectType (ObjectType m) + | NonNullInterfaceType (InterfaceType m) + | NonNullUnionType (UnionType m) + | NonNullListType (Type m) + deriving Eq + +-- | Matches either 'NamedScalarType' or 'NonNullScalarType'. +pattern ScalarBaseType :: forall m. ScalarType -> Type m +pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType) + +-- | Matches either 'NamedEnumType' or 'NonNullEnumType'. +pattern EnumBaseType :: forall m. EnumType -> Type m +pattern EnumBaseType enumType <- (isEnumType -> Just enumType) + +-- | Matches either 'NamedObjectType' or 'NonNullObjectType'. +pattern ObjectBaseType :: forall m. ObjectType m -> Type m +pattern ObjectBaseType objectType <- (isObjectType -> Just objectType) + +-- | Matches either 'NamedInterfaceType' or 'NonNullInterfaceType'. +pattern InterfaceBaseType :: forall m. InterfaceType m -> Type m +pattern InterfaceBaseType interfaceType <- + (isInterfaceType -> Just interfaceType) + +-- | Matches either 'NamedUnionType' or 'NonNullUnionType'. +pattern UnionBaseType :: forall m. UnionType m -> Type m +pattern UnionBaseType unionType <- (isUnionType -> Just unionType) + +-- | Matches either 'ListType' or 'NonNullListType'. +pattern ListBaseType :: forall m. Type m -> Type m +pattern ListBaseType listType <- (isListType -> Just listType) + +{-# COMPLETE ScalarBaseType + , EnumBaseType + , ObjectBaseType + , ListBaseType + , InterfaceBaseType + , UnionBaseType + #-} + +isScalarType :: forall m. Type m -> Maybe ScalarType +isScalarType (NamedScalarType outputType) = Just outputType +isScalarType (NonNullScalarType outputType) = Just outputType +isScalarType _ = Nothing + +isObjectType :: forall m. Type m -> Maybe (ObjectType m) +isObjectType (NamedObjectType outputType) = Just outputType +isObjectType (NonNullObjectType outputType) = Just outputType +isObjectType _ = Nothing + +isEnumType :: forall m. Type m -> Maybe EnumType +isEnumType (NamedEnumType outputType) = Just outputType +isEnumType (NonNullEnumType outputType) = Just outputType +isEnumType _ = Nothing + +isInterfaceType :: forall m. Type m -> Maybe (InterfaceType m) +isInterfaceType (NamedInterfaceType interfaceType) = Just interfaceType +isInterfaceType (NonNullInterfaceType interfaceType) = Just interfaceType +isInterfaceType _ = Nothing + +isUnionType :: forall m. Type m -> Maybe (UnionType m) +isUnionType (NamedUnionType unionType) = Just unionType +isUnionType (NonNullUnionType unionType) = Just unionType +isUnionType _ = Nothing + +isListType :: forall m. Type m -> Maybe (Type m) +isListType (ListType outputType) = Just outputType +isListType (NonNullListType outputType) = Just outputType +isListType _ = Nothing + +-- | Checks whether the given output type is a non-null type. +isNonNullType :: forall m. Type m -> Bool +isNonNullType (NonNullScalarType _) = True +isNonNullType (NonNullEnumType _) = True +isNonNullType (NonNullObjectType _) = True +isNonNullType (NonNullInterfaceType _) = True +isNonNullType (NonNullUnionType _) = True +isNonNullType (NonNullListType _) = True +isNonNullType _ = False diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/Type/Schema.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ExplicitForAll #-} + +-- | This module provides a representation of a @GraphQL@ Schema in addition to +-- functions for defining and manipulating schemas. +module Language.GraphQL.Type.Schema + ( AbstractType(..) + , CompositeType(..) + , Schema(..) + , Type(..) + , collectReferencedTypes + ) where + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL.AST.Document (Name) +import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out + +-- | These are all of the possible kinds of types. +data Type m + = ScalarType Definition.ScalarType + | EnumType Definition.EnumType + | ObjectType (Out.ObjectType m) + | InputObjectType In.InputObjectType + | InterfaceType (Out.InterfaceType m) + | UnionType (Out.UnionType m) + deriving Eq + +-- | These types may describe the parent context of a selection set. +data CompositeType m + = CompositeUnionType (Out.UnionType m) + | CompositeObjectType (Out.ObjectType m) + | CompositeInterfaceType (Out.InterfaceType m) + deriving Eq + +-- | These types may describe the parent context of a selection set. +data AbstractType m + = AbstractUnionType (Out.UnionType m) + | AbstractInterfaceType (Out.InterfaceType m) + deriving Eq + +-- | 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 + { query :: Out.ObjectType m + , mutation :: Maybe (Out.ObjectType m) + } + +-- | Traverses the schema and finds all referenced types. +collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m) +collectReferencedTypes schema = + let queryTypes = traverseObjectType (query schema) HashMap.empty + in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema + where + collect traverser typeName element foundTypes + | HashMap.member typeName foundTypes = foundTypes + | otherwise = traverser $ HashMap.insert typeName element foundTypes + visitFields (Out.Field _ outputType arguments) foundTypes + = traverseOutputType outputType + $ foldr visitArguments foundTypes arguments + visitArguments (In.Argument _ inputType _) = traverseInputType inputType + visitInputFields (In.InputField _ inputType _) = traverseInputType inputType + traverseInputType (In.InputObjectBaseType objectType) = + let (In.InputObjectType typeName _ inputFields) = objectType + element = InputObjectType objectType + traverser = flip (foldr visitInputFields) inputFields + in collect traverser typeName element + traverseInputType (In.ListBaseType listType) = + traverseInputType listType + traverseInputType (In.ScalarBaseType scalarType) = + let (Definition.ScalarType typeName _) = scalarType + in collect Prelude.id typeName (ScalarType scalarType) + traverseInputType (In.EnumBaseType enumType) = + let (Definition.EnumType typeName _ _) = enumType + in collect Prelude.id typeName (EnumType enumType) + traverseOutputType (Out.ObjectBaseType objectType) = + traverseObjectType objectType + traverseOutputType (Out.InterfaceBaseType interfaceType) = + traverseInterfaceType interfaceType + traverseOutputType (Out.UnionBaseType unionType) = + let (Out.UnionType typeName _ types) = unionType + traverser = flip (foldr traverseObjectType) types + in collect traverser typeName (UnionType unionType) + traverseOutputType (Out.ListBaseType listType) = + traverseOutputType listType + traverseOutputType (Out.ScalarBaseType scalarType) = + let (Definition.ScalarType typeName _) = scalarType + in collect Prelude.id typeName (ScalarType scalarType) + traverseOutputType (Out.EnumBaseType enumType) = + let (Definition.EnumType typeName _ _) = enumType + in collect Prelude.id typeName (EnumType enumType) + traverseObjectType objectType foundTypes = + let (Out.ObjectType typeName _ interfaces resolvers) = objectType + element = ObjectType objectType + fields = extractObjectField <$> resolvers + traverser = polymorphicTraverser interfaces fields + in collect traverser typeName element foundTypes + traverseInterfaceType interfaceType foundTypes = + let (Out.InterfaceType typeName _ interfaces fields) = interfaceType + element = InterfaceType interfaceType + traverser = polymorphicTraverser interfaces fields + in collect traverser typeName element foundTypes + polymorphicTraverser interfaces fields + = flip (foldr visitFields) fields + . flip (foldr traverseInterfaceType) interfaces + extractObjectField (Out.Resolver field _) = field diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -8,7 +8,7 @@ import Language.GraphQL.AST.Document import Language.GraphQL.AST.Parser import Test.Hspec (Spec, describe, it) -import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn) +import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (parse) import Text.RawString.QQ (r) @@ -140,5 +140,12 @@ parse document "" `shouldSucceedOn` [r| extend type Story { isHiddenLocally: Boolean + } + |] + + it "rejects variables in DefaultValue" $ + parse document "" `shouldFailOn` [r| + query ($book: String = "Zarathustra", $author: String = $book) { + title } |] diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.GraphQL.Execute.CoerceSpec + ( spec + ) where + +import Data.Aeson as Aeson ((.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (isNothing) +import Data.Scientific (scientific) +import qualified Language.GraphQL.Execute.Coerce as Coerce +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.In as In +import Prelude hiding (id) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +direction :: EnumType +direction = EnumType "Direction" Nothing $ HashMap.fromList + [ ("NORTH", EnumValue Nothing) + , ("EAST", EnumValue Nothing) + , ("SOUTH", EnumValue Nothing) + , ("WEST", EnumValue Nothing) + ] + +singletonInputObject :: In.Type +singletonInputObject = In.NamedInputObjectType type' + where + type' = In.InputObjectType "ObjectName" Nothing inputFields + inputFields = HashMap.singleton "field" field + field = In.InputField Nothing (In.NamedScalarType string) Nothing + +namedIdType :: In.Type +namedIdType = In.NamedScalarType id + +spec :: Spec +spec = do + describe "VariableValue Aeson" $ do + it "coerces strings" $ + let expected = Just (String "asdf") + actual = Coerce.coerceVariableValue + (In.NamedScalarType string) (Aeson.String "asdf") + in actual `shouldBe` expected + it "coerces non-null strings" $ + let expected = Just (String "asdf") + actual = Coerce.coerceVariableValue + (In.NonNullScalarType string) (Aeson.String "asdf") + in actual `shouldBe` expected + it "coerces booleans" $ + let expected = Just (Boolean True) + actual = Coerce.coerceVariableValue + (In.NamedScalarType boolean) (Aeson.Bool True) + in actual `shouldBe` expected + it "coerces zero to an integer" $ + let expected = Just (Int 0) + actual = Coerce.coerceVariableValue + (In.NamedScalarType int) (Aeson.Number 0) + in actual `shouldBe` expected + it "rejects fractional if an integer is expected" $ + let actual = Coerce.coerceVariableValue + (In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1)) + in actual `shouldSatisfy` isNothing + it "coerces float numbers" $ + let expected = Just (Float 1.4) + actual = Coerce.coerceVariableValue + (In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1)) + in actual `shouldBe` expected + it "coerces IDs" $ + let expected = Just (String "1234") + json = Aeson.String "1234" + actual = Coerce.coerceVariableValue namedIdType json + in actual `shouldBe` expected + it "coerces input objects" $ + let actual = Coerce.coerceVariableValue singletonInputObject + $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)] + expected = Just $ Object $ HashMap.singleton "field" "asdf" + in actual `shouldBe` expected + it "skips the field if it is missing in the variables" $ + let actual = Coerce.coerceVariableValue + singletonInputObject Aeson.emptyObject + expected = Just $ Object HashMap.empty + in actual `shouldBe` expected + it "fails if input object value contains extra fields" $ + let actual = Coerce.coerceVariableValue singletonInputObject + $ Aeson.object variableFields + variableFields = + [ "field" .= ("asdf" :: Aeson.Value) + , "extra" .= ("qwer" :: Aeson.Value) + ] + in actual `shouldSatisfy` isNothing + it "preserves null" $ + let actual = Coerce.coerceVariableValue namedIdType Aeson.Null + in actual `shouldBe` Just Null + it "preserves list order" $ + let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"] + listType = (In.ListType $ In.NamedScalarType string) + actual = Coerce.coerceVariableValue listType list + expected = Just $ List [String "asdf", String "qwer"] + in actual `shouldBe` expected + + describe "coerceInputLiteral" $ do + it "coerces enums" $ + let expected = Just (Enum "NORTH") + actual = Coerce.coerceInputLiteral + (In.NamedEnumType direction) (Enum "NORTH") + in actual `shouldBe` expected + it "fails with non-existing enum value" $ + let actual = Coerce.coerceInputLiteral + (In.NamedEnumType direction) (Enum "NORTH_EAST") + in actual `shouldSatisfy` isNothing + it "coerces integers to IDs" $ + let expected = Just (String "1234") + actual = Coerce.coerceInputLiteral namedIdType (Int 1234) + in actual `shouldBe` expected + it "coerces nulls" $ do + let actual = Coerce.coerceInputLiteral namedIdType Null + in actual `shouldBe` Just Null + it "wraps singleton lists" $ do + let expected = Just $ List [List [String "1"]] + embeddedType = In.ListType $ In.ListType namedIdType + actual = Coerce.coerceInputLiteral embeddedType (String "1") + in actual `shouldBe` expected diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.GraphQL.ExecuteSpec + ( spec + ) where + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.Functor.Identity (Identity(..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL.AST (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 Test.Hspec (Spec, describe, it, shouldBe) +import Text.Megaparsec (parse) + +schema :: Schema Identity +schema = Schema {query = queryType, mutation = Nothing} + +queryType :: Out.ObjectType Identity +queryType = Out.ObjectType "Query" Nothing [] + $ HashMap.singleton "philosopher" + $ Out.Resolver philosopherField + $ pure + $ Type.Object mempty + where + philosopherField = + Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty + +philosopherType :: Out.ObjectType Identity +philosopherType = Out.ObjectType "Philosopher" Nothing [] + $ HashMap.fromList resolvers + where + resolvers = + [ ("firstName", firstNameResolver) + , ("lastName", lastNameResolver) + ] + firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich" + lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche" + firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + +spec :: Spec +spec = + describe "execute" $ do + it "skips unknown fields" $ + let expected = Aeson.object + [ "data" .= Aeson.object + [ "philosopher" .= Aeson.object + [ "firstName" .= ("Friedrich" :: String) + ] + ] + ] + execute' = execute schema (mempty :: HashMap Name Aeson.Value) + actual = runIdentity + $ either parseError execute' + $ parse document "" "{ philosopher { firstName surname } }" + in actual `shouldBe` expected + it "merges selections" $ + let expected = Aeson.object + [ "data" .= Aeson.object + [ "philosopher" .= Aeson.object + [ "firstName" .= ("Friedrich" :: String) + , "lastName" .= ("Nietzsche" :: String) + ] + ] + ] + execute' = execute schema (mempty :: HashMap Name Aeson.Value) + actual = runIdentity + $ either parseError execute' + $ parse document "" "{ philosopher { firstName } philosopher { lastName } }" + in actual `shouldBe` expected diff --git a/tests/Language/GraphQL/Type/OutSpec.hs b/tests/Language/GraphQL/Type/OutSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/GraphQL/Type/OutSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.GraphQL.Type.OutSpec + ( spec + ) where + +import Language.GraphQL.Type +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = + describe "Value" $ + it "supports overloaded strings" $ + let nietzsche = "Goldstaub abblasen." :: Value + in nietzsche `shouldBe` String "Goldstaub abblasen." diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -4,21 +4,24 @@ ( spec ) where -import Data.Aeson (Value, object, (.=)) -import Data.HashMap.Strict (HashMap) +import Data.Aeson (object, (.=)) +import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Text (Text) import Language.GraphQL -import qualified Language.GraphQL.Schema as Schema +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.Out as Out import Test.Hspec (Spec, describe, it, shouldBe) import Text.RawString.QQ (r) -experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO)) -experimentalResolver = HashMap.singleton "Query" - $ Schema.scalar "experimentalField" (pure (5 :: Int)) :| [] +experimentalResolver :: Schema IO +experimentalResolver = Schema { query = queryType, mutation = Nothing } + where + resolver = pure $ Int 5 + queryType = Out.ObjectType "Query" Nothing [] + $ HashMap.singleton "experimentalField" + $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) resolver -emptyObject :: Value +emptyObject :: Aeson.Value emptyObject = object [ "data" .= object [] ] @@ -27,17 +30,17 @@ spec = describe "Directive executor" $ do it "should be able to @skip fields" $ do - let query = [r| + let sourceQuery = [r| { experimentalField @skip(if: true) } |] - actual <- graphql experimentalResolver query + actual <- graphql experimentalResolver sourceQuery actual `shouldBe` emptyObject it "should not skip fields if @skip is false" $ do - let query = [r| + let sourceQuery = [r| { experimentalField @skip(if: false) } @@ -48,21 +51,21 @@ ] ] - actual <- graphql experimentalResolver query + actual <- graphql experimentalResolver sourceQuery actual `shouldBe` expected it "should skip fields if @include is false" $ do - let query = [r| + let sourceQuery = [r| { experimentalField @include(if: false) } |] - actual <- graphql experimentalResolver query + actual <- graphql experimentalResolver sourceQuery actual `shouldBe` emptyObject it "should be able to @skip a fragment spread" $ do - let query = [r| + let sourceQuery = [r| { ...experimentalFragment @skip(if: true) } @@ -72,11 +75,11 @@ } |] - actual <- graphql experimentalResolver query + actual <- graphql experimentalResolver sourceQuery actual `shouldBe` emptyObject it "should be able to @skip an inline fragment" $ do - let query = [r| + let sourceQuery = [r| { ... on ExperimentalType @skip(if: true) { experimentalField @@ -84,5 +87,5 @@ } |] - actual <- graphql experimentalResolver query + actual <- graphql experimentalResolver sourceQuery actual `shouldBe` emptyObject diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -4,32 +4,35 @@ ( spec ) where -import Data.Aeson (Value(..), object, (.=)) +import Data.Aeson (object, (.=)) +import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap -import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import Language.GraphQL -import qualified Language.GraphQL.Schema as Schema -import Test.Hspec ( Spec - , describe - , it - , shouldBe - , shouldSatisfy - , shouldNotSatisfy - ) +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.Out as Out +import Test.Hspec + ( Spec + , describe + , it + , shouldBe + , shouldNotSatisfy + ) import Text.RawString.QQ (r) -size :: Schema.Resolver IO -size = Schema.scalar "size" $ return ("L" :: Text) +size :: (Text, Value) +size = ("size", String "L") -circumference :: Schema.Resolver IO -circumference = Schema.scalar "circumference" $ return (60 :: Int) +circumference :: (Text, Value) +circumference = ("circumference", Int 60) -garment :: Text -> Schema.Resolver IO -garment typeName = Schema.object "garment" $ return - [ if typeName == "Hat" then circumference else size - , Schema.scalar "__typename" $ return typeName - ] +garment :: Text -> (Text, Value) +garment typeName = + ("garment", Object $ HashMap.fromList + [ if typeName == "Hat" then circumference else size + , ("__typename", String typeName) + ] + ) inlineQuery :: Text inlineQuery = [r|{ @@ -43,15 +46,52 @@ } }|] -hasErrors :: Value -> Bool -hasErrors (Object object') = HashMap.member "errors" object' +hasErrors :: Aeson.Value -> Bool +hasErrors (Aeson.Object object') = HashMap.member "errors" object' hasErrors _ = True +shirtType :: Out.ObjectType IO +shirtType = Out.ObjectType "Shirt" Nothing [] + $ HashMap.fromList + [ ("size", Out.Resolver sizeFieldType $ pure $ snd size) + , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference) + ] + +hatType :: Out.ObjectType IO +hatType = Out.ObjectType "Hat" Nothing [] + $ HashMap.fromList + [ ("size", Out.Resolver sizeFieldType $ pure $ snd size) + , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference) + ] + +circumferenceFieldType :: Out.Field IO +circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty + +sizeFieldType :: Out.Field IO +sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty + +toSchema :: Text -> (Text, Value) -> Schema IO +toSchema t (_, resolve) = Schema + { query = queryType, mutation = Nothing } + where + unionMember = if t == "Hat" then hatType else shirtType + typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty + garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty + queryType = + case t of + "circumference" -> hatType + "size" -> shirtType + _ -> Out.ObjectType "Query" Nothing [] + $ HashMap.fromList + [ ("garment", Out.Resolver garmentField $ pure resolve) + , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt") + ] + spec :: Spec spec = do describe "Inline fragment executor" $ do it "chooses the first selection if the type matches" $ do - actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery + actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery let expected = object [ "data" .= object [ "garment" .= object @@ -62,7 +102,7 @@ in actual `shouldBe` expected it "chooses the last selection if the type matches" $ do - actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery + actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery let expected = object [ "data" .= object [ "garment" .= object @@ -73,7 +113,7 @@ in actual `shouldBe` expected it "embeds inline fragments without type" $ do - let query = [r|{ + let sourceQuery = [r|{ garment { circumference ... { @@ -81,9 +121,9 @@ } } }|] - resolvers = Schema.object "garment" $ return [circumference, size] + resolvers = ("garment", Object $ HashMap.fromList [circumference, size]) - actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query + actual <- graphql (toSchema "garment" resolvers) sourceQuery let expected = object [ "data" .= object [ "garment" .= object @@ -95,18 +135,18 @@ in actual `shouldBe` expected it "evaluates fragments on Query" $ do - let query = [r|{ + let sourceQuery = [r|{ ... { size } }|] - actual <- graphql (HashMap.singleton "Query" $ size :| []) query + actual <- graphql (toSchema "size" size) sourceQuery actual `shouldNotSatisfy` hasErrors describe "Fragment spread executor" $ do it "evaluates fragment spreads" $ do - let query = [r| + let sourceQuery = [r| { ...circumferenceFragment } @@ -116,7 +156,7 @@ } |] - actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query + actual <- graphql (toSchema "circumference" circumference) sourceQuery let expected = object [ "data" .= object [ "circumference" .= (60 :: Int) @@ -125,7 +165,7 @@ in actual `shouldBe` expected it "evaluates nested fragments" $ do - let query = [r| + let sourceQuery = [r| { garment { ...circumferenceFragment @@ -141,7 +181,7 @@ } |] - actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query + actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery let expected = object [ "data" .= object [ "garment" .= object @@ -152,7 +192,10 @@ in actual `shouldBe` expected it "rejects recursive fragments" $ do - let query = [r| + let expected = object + [ "data" .= object [] + ] + sourceQuery = [r| { ...circumferenceFragment } @@ -162,11 +205,11 @@ } |] - actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query - actual `shouldSatisfy` hasErrors + actual <- graphql (toSchema "circumference" circumference) sourceQuery + actual `shouldBe` expected it "considers type condition" $ do - let query = [r| + let sourceQuery = [r| { garment { ...circumferenceFragment @@ -187,5 +230,5 @@ ] ] ] - actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query + actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery actual `shouldBe` expected diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RootOperationSpec.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Test.RootOperationSpec + ( spec + ) where + +import Data.Aeson ((.=), object) +import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL +import Test.Hspec (Spec, describe, it, shouldBe) +import Text.RawString.QQ (r) +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.Out as Out + +hatType :: Out.ObjectType IO +hatType = Out.ObjectType "Hat" Nothing [] + $ HashMap.singleton "circumference" + $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) + $ pure $ Int 60 + +schema :: Schema IO +schema = Schema + (Out.ObjectType "Query" Nothing [] hatField) + (Just $ Out.ObjectType "Mutation" Nothing [] incrementField) + where + garment = pure $ Object $ HashMap.fromList + [ ("circumference", Int 60) + ] + incrementField = HashMap.singleton "incrementCircumference" + $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) + $ pure $ Int 61 + hatField = HashMap.singleton "garment" + $ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment + +spec :: Spec +spec = + describe "Root operation type" $ do + it "returns objects from the root resolvers" $ do + let querySource = [r| + { + garment { + circumference + } + } + |] + expected = object + [ "data" .= object + [ "garment" .= object + [ "circumference" .= (60 :: Int) + ] + ] + ] + actual <- graphql schema querySource + actual `shouldBe` expected + + it "chooses Mutation" $ do + let querySource = [r| + mutation { + incrementCircumference + } + |] + expected = object + [ "data" .= object + [ "incrementCircumference" .= (61 :: Int) + ] + ] + actual <- graphql schema querySource + actual `shouldBe` expected diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -11,7 +11,7 @@ , getHuman , id_ , homePlanet - , name + , name_ , secretBackstory , typeName ) where @@ -22,7 +22,6 @@ import Data.Maybe (catMaybes) import Data.Text (Text) import Language.GraphQL.Trans -import qualified Language.GraphQL.Type as Type -- * Data -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js @@ -55,9 +54,9 @@ id_ (Left x) = _id_ . _droidChar $ x id_ (Right x) = _id_ . _humanChar $ x -name :: Character -> Text -name (Left x) = _name . _droidChar $ x -name (Right x) = _name . _humanChar $ x +name_ :: Character -> Text +name_ (Left x) = _name . _droidChar $ x +name_ (Right x) = _name . _humanChar $ x friends :: Character -> [ID] friends (Left x) = _friends . _droidChar $ x @@ -67,8 +66,8 @@ appearsIn (Left x) = _appearsIn . _droidChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x -secretBackstory :: Character -> ActionT Identity Text -secretBackstory = const $ ActionT $ throwE "secretBackstory is secret." +secretBackstory :: ActionT Identity Text +secretBackstory = ActionT $ throwE "secretBackstory is secret." typeName :: Character -> Text typeName = either (const "Droid") (const "Human") @@ -184,8 +183,8 @@ getFriends :: Character -> [Character] getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char -getEpisode :: Int -> Maybe (Type.Wrapping Text) -getEpisode 4 = pure $ Type.Named "NEWHOPE" -getEpisode 5 = pure $ Type.Named "EMPIRE" -getEpisode 6 = pure $ Type.Named "JEDI" +getEpisode :: Int -> Maybe Text +getEpisode 4 = pure "NEW_HOPE" +getEpisode 5 = pure "EMPIRE" +getEpisode 6 = pure "JEDI" getEpisode _ = empty diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -10,7 +10,6 @@ import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Language.GraphQL -import Language.GraphQL.Schema (Subs) import Text.RawString.QQ (r) import Test.Hspec.Expectations (Expectation, shouldBe) import Test.Hspec (Spec, describe, it) @@ -40,7 +39,7 @@ id name friends { - name + name } } } @@ -65,9 +64,9 @@ friends { name appearsIn - friends { - name - } + friends { + name + } } } } @@ -78,7 +77,7 @@ , "friends" .= [ Aeson.object [ "name" .= ("Luke Skywalker" :: Text) - , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text] + , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text] , "friends" .= [ Aeson.object [hanName] , Aeson.object [leiaName] @@ -88,7 +87,7 @@ ] , Aeson.object [ hanName - , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] + , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text] , "friends" .= [ Aeson.object [lukeName] , Aeson.object [leiaName] @@ -97,7 +96,7 @@ ] , Aeson.object [ leiaName - , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] + , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text] , "friends" .= [ Aeson.object [lukeName] , Aeson.object [hanName] @@ -360,6 +359,6 @@ testQuery :: Text -> Aeson.Value -> Expectation testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected -testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation +testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation testQueryParams f q expected = runIdentity (graphqlSubs schema f q) `shouldBe` expected diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -1,66 +1,133 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.StarWars.Schema - ( character - , droid - , hero - , human - , schema + ( schema ) where +import Control.Monad.Trans.Reader (asks) import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Class (lift) import Data.Functor.Identity (Identity) -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes) import Data.Text (Text) -import qualified Language.GraphQL.Schema as Schema import Language.GraphQL.Trans -import qualified Language.GraphQL.Type as Type +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out import Test.StarWars.Data +import Prelude hiding (id) -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: HashMap Text (NonEmpty (Schema.Resolver Identity)) -schema = HashMap.singleton "Query" $ hero :| [human, droid] +schema :: Schema Identity +schema = Schema { query = queryType, mutation = Nothing } + where + queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList + [ ("hero", Out.Resolver heroField hero) + , ("human", Out.Resolver humanField human) + , ("droid", Out.Resolver droidField droid) + ] + heroField = Out.Field Nothing (Out.NamedObjectType heroObject) + $ HashMap.singleton "episode" + $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing + humanField = Out.Field Nothing (Out.NamedObjectType heroObject) + $ HashMap.singleton "id" + $ In.Argument Nothing (In.NonNullScalarType string) Nothing + droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty -hero :: Schema.Resolver Identity -hero = Schema.object "hero" $ do +heroObject :: Out.ObjectType Identity +heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList + [ ("id", Out.Resolver idFieldType (idField "id")) + , ("name", Out.Resolver nameFieldType (idField "name")) + , ("friends", Out.Resolver friendsFieldType (idField "friends")) + , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn")) + , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet")) + , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory)) + , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename")) + ] + where + homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty + +droidObject :: Out.ObjectType Identity +droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList + [ ("id", Out.Resolver idFieldType (idField "id")) + , ("name", Out.Resolver nameFieldType (idField "name")) + , ("friends", Out.Resolver friendsFieldType (idField "friends")) + , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn")) + , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction")) + , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory)) + , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename")) + ] + where + primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty + +idFieldType :: Out.Field Identity +idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty + +nameFieldType :: Out.Field Identity +nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty + +friendsFieldType :: Out.Field Identity +friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty + +appearsInField :: Out.Field Identity +appearsInField = Out.Field (Just description) fieldType mempty + where + fieldType = Out.ListType $ Out.NamedEnumType episodeEnum + description = "Which movies they appear in." + +secretBackstoryFieldType :: Out.Field Identity +secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty + +idField :: Text -> ActionT Identity Value +idField f = do + v <- ActionT $ lift $ asks values + let (Object v') = v + pure $ v' HashMap.! f + +episodeEnum :: EnumType +episodeEnum = EnumType "Episode" (Just description) + $ HashMap.fromList [newHope, empire, jedi] + where + description = "One of the films in the Star Wars Trilogy" + newHope = ("NEW_HOPE", EnumValue $ Just "Released in 1977.") + empire = ("EMPIRE", EnumValue $ Just "Released in 1980.") + jedi = ("JEDI", EnumValue $ Just "Released in 1983.") + +hero :: ActionT Identity Value +hero = do episode <- argument "episode" - character $ case episode of - Schema.Enum "NEWHOPE" -> getHero 4 - Schema.Enum "EMPIRE" -> getHero 5 - Schema.Enum "JEDI" -> getHero 6 + pure $ character $ case episode of + Enum "NEW_HOPE" -> getHero 4 + Enum "EMPIRE" -> getHero 5 + Enum "JEDI" -> getHero 6 _ -> artoo -human :: Schema.Resolver Identity -human = Schema.wrappedObject "human" $ do +human :: ActionT Identity Value +human = do id' <- argument "id" case id' of - Schema.String i -> do + String i -> do humanCharacter <- lift $ return $ getHuman i >>= Just case humanCharacter of - Nothing -> return Type.Null - Just e -> Type.Named <$> character e + Nothing -> pure Null + Just e -> pure $ character e _ -> ActionT $ throwE "Invalid arguments." -droid :: Schema.Resolver Identity -droid = Schema.object "droid" $ do +droid :: ActionT Identity Value +droid = do id' <- argument "id" case id' of - Schema.String i -> character =<< getDroid i + String i -> character <$> getDroid i _ -> ActionT $ throwE "Invalid arguments." -character :: Character -> ActionT Identity [Schema.Resolver Identity] -character char = return - [ Schema.scalar "id" $ return $ id_ char - , Schema.scalar "name" $ return $ name char - , Schema.wrappedObject "friends" - $ traverse character $ Type.List $ Type.Named <$> getFriends char - , Schema.wrappedScalar "appearsIn" $ return . Type.List - $ catMaybes (getEpisode <$> appearsIn char) - , Schema.scalar "secretBackstory" $ secretBackstory char - , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char - , Schema.scalar "__typename" $ return $ typeName char +character :: Character -> Value +character char = Object $ HashMap.fromList + [ ("id", String $ id_ char) + , ("name", String $ name_ char) + , ("friends", List $ character <$> getFriends char) + , ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char)) + , ("homePlanet", String $ either mempty homePlanet char) + , ("__typename", String $ typeName char) ]