prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Define resolvers on type fields

Browse Source 
Returning resolvers from other resolvers isn't supported anymore. Since
we have a type system now, we define the resolvers in the object type
fields and pass an object with the previous result to them.
This commit is contained in:
Eugen Wissner 2020-05-27 23:18:35 +02:00
parent c06d0b8e95
commit d12577ae71
25 changed files with 534 additions and 516 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
CHANGELOG.md
View File

@ -18,17 +18,14 @@ and this project adheres to
### Changed ### Changed
- `Schema.Resolver` cannot return arbitrary JSON anymore, but only - `Schema.Resolver` cannot return arbitrary JSON anymore, but only
`Type.Out.Value`. `Type.Definition.Value`.
- `Schema.object` takes an array of field resolvers (name, value pairs) and - `AST.Core.Value` was moved into `Type.Definition`. These values are used only
returns a resolver (just the function). There is no need in special functions in the execution and type system, it is not a part of the parsing tree.
to construct field resolvers anymore, they can be constructed with just
`Resolver "fieldName" $ pure $ object [...]`.
- `AST.Core.Document` was modified to contain only slightly modified AST and
moved into `Execute.Transform.Document`.
- `AST.Core.Value` was moved into `Type.In`. Input 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 - `Type` module is superseded by `Type.Out`. This module contains now only
exports from other module that complete `Type.In` and `Type.Out` exports. 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 ### Added
- `Type.Definition` contains base type system definition, e.g. Enums and - `Type.Definition` contains base type system definition, e.g. Enums and
@ -43,16 +40,18 @@ and this project adheres to
`Subs`, where a is an instance of `VariableValue`. `Subs`, where a is an instance of `VariableValue`.
### Removed ### Removed
- `Execute.Transform.document`. Transforming the whole document is probably not
reasonable since a document can define multiple operations and we're
interested only in one of them. `Execute.Transform.operation` has the prior
responsibility of `Execute.Transform.document`, but transforms only the
chosen operation and not the whole document.
- `Schema.scalar`, `Schema.wrappedScalar`. They accepted everything can be - `Schema.scalar`, `Schema.wrappedScalar`. They accepted everything can be
converted to JSON and JSON is not suitable as an internal representation for converted to JSON and JSON is not suitable as an internal representation for
GraphQL. E.g. GraphQL distinguishes between Floats and Integersa and we need GraphQL. E.g. GraphQL distinguishes between Floats and Integers.
a way to represent objects as a "Field Name -> Resolver" map. - `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no
- `Schema.wrappedObject`. `Schema.object` creates now wrapped objects. need in special functions to construct field resolvers anymore, resolvers are
normal functions attached to the fields in the schema representation.
- `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.
## [0.7.0.0] - 2020-05-11 ## [0.7.0.0] - 2020-05-11
### Fixed ### Fixed

8
docs/tutorial/tutorial.lhs
View File

@ -44,8 +44,8 @@ First we build a GraphQL schema.
> $ HashMap.singleton "hello" > $ HashMap.singleton "hello"
> $ Field Nothing (Out.NamedScalarType string) mempty hello > $ Field Nothing (Out.NamedScalarType string) mempty hello
> >
> hello :: ActionT IO (Out.Value IO) > hello :: ActionT IO Value
> hello = pure $ Out.String "it's me" > hello = pure $ String "it's me"
This defines a simple schema with one type and one field, that resolves to a fixed value. This defines a simple schema with one type and one field, that resolves to a fixed value.
@ -79,10 +79,10 @@ For this example, we're going to be using time.
> $ HashMap.singleton "time" > $ HashMap.singleton "time"
> $ Field Nothing (Out.NamedScalarType string) mempty time > $ Field Nothing (Out.NamedScalarType string) mempty time
> >
> time :: ActionT IO (Out.Value IO) > time :: ActionT IO Value
> time = do > time = do
> t <- liftIO getCurrentTime > t <- liftIO getCurrentTime
> pure $ Out.String $ Text.pack $ show t > pure $ String $ Text.pack $ show t
This defines a simple schema with one type and one field, This defines a simple schema with one type and one field,
which resolves to the current time. which resolves to the current time.

1
package.yaml
View File

@ -40,6 +40,7 @@ dependencies:
library: library:
source-dirs: src source-dirs: src
other-modules: other-modules:
- Language.GraphQL.Execute.Execution
- Language.GraphQL.Execute.Transform - Language.GraphQL.Execute.Transform
- Language.GraphQL.Type.Directive - Language.GraphQL.Type.Directive

44
src/Language/GraphQL/AST/Core.hs
View File

@ -1,37 +1,15 @@
-- | This is the AST meant to be executed. -- | This is the AST meant to be executed.
module Language.GraphQL.AST.Core module Language.GraphQL.AST.Core
( Alias ( Arguments(..)
, Arguments(..)
, Directive(..)
, Field(..)
, Fragment(..)
, Name , Name
, Operation(..)
, Selection(..)
, TypeCondition
) where ) where
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq) import Language.GraphQL.AST (Name)
import Data.Text (Text) import Language.GraphQL.Type.Definition
import Language.GraphQL.AST (Alias, Name, TypeCondition)
import qualified Language.GraphQL.Type.In as In
-- | 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)
-- | Argument list. -- | Argument list.
newtype Arguments = Arguments (HashMap Name In.Value) newtype Arguments = Arguments (HashMap Name Value)
deriving (Eq, Show) deriving (Eq, Show)
instance Semigroup Arguments where instance Semigroup Arguments where
@ -40,17 +18,3 @@ instance Semigroup Arguments where
instance Monoid Arguments where instance Monoid Arguments where
mempty = Arguments mempty 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)

50
src/Language/GraphQL/Error.hs
View File

@ -5,21 +5,20 @@
module Language.GraphQL.Error module Language.GraphQL.Error
( parseError ( parseError
, CollectErrsT , CollectErrsT
, Resolution(..)
, addErr , addErr
, addErrMsg , addErrMsg
, runCollectErrs , runCollectErrs
, runAppendErrs
, singleError , singleError
) where ) where
import Control.Monad.Trans.State (StateT, modify, runStateT)
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import Data.Text (Text) import Data.Text (Text)
import Data.Void (Void) import Data.Void (Void)
import Control.Monad.Trans.Class (lift) import Language.GraphQL.AST.Document (Name)
import Control.Monad.Trans.State ( StateT import Language.GraphQL.Type.Schema
, modify
, runStateT
)
import Text.Megaparsec import Text.Megaparsec
( ParseErrorBundle(..) ( ParseErrorBundle(..)
, PosState(..) , PosState(..)
@ -30,6 +29,11 @@ import Text.Megaparsec
, unPos , unPos
) )
data Resolution m = Resolution
{ errors :: [Aeson.Value]
, types :: HashMap Name (Type m)
}
-- | Wraps a parse error into a list of errors. -- | Wraps a parse error into a list of errors.
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
parseError ParseErrorBundle{..} = parseError ParseErrorBundle{..} =
@ -46,11 +50,13 @@ parseError ParseErrorBundle{..} =
in (errorObject x sourcePosition : result, newState) in (errorObject x sourcePosition : result, newState)
-- | A wrapper to pass error messages around. -- | 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. -- | Adds an error to the list of errors.
addErr :: Monad m => Aeson.Value -> CollectErrsT m () 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 :: Text -> Aeson.Value
makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)] makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]
@ -66,23 +72,17 @@ singleError message = Aeson.object
addErrMsg :: Monad m => Text -> CollectErrsT m () addErrMsg :: Monad m => Text -> CollectErrsT m ()
addErrMsg = addErr . makeErrorMessage 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 -- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data. -- list, which is then sent back with the data.
runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value runCollectErrs :: Monad m
runCollectErrs res = do => HashMap Name (Type m)
(dat, errs) <- runStateT res [] -> CollectErrsT m Aeson.Value
if null errs -> m Aeson.Value
runCollectErrs types' res = do
(dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' }
if null errors
then return $ Aeson.object [("data", dat)] then return $ Aeson.object [("data", dat)]
else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)] else return $ Aeson.object
[ ("data", dat)
-- | Runs the given computation, collecting the errors and appending them , ("errors", Aeson.toJSON $ reverse errors)
-- 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

32
src/Language/GraphQL/Execute.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
-- | This module provides functions to execute a @GraphQL@ request. -- | This module provides functions to execute a @GraphQL@ request.
module Language.GraphQL.Execute module Language.GraphQL.Execute
( execute ( execute
@ -8,14 +5,15 @@ module Language.GraphQL.Execute
) where ) where
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq(..)) import Data.Sequence (Seq(..))
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document (Document, Name)
import qualified Language.GraphQL.AST.Core as AST.Core
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
@ -56,22 +54,18 @@ executeRequest :: (Monad m, VariableValue a)
executeRequest schema operationName subs document = executeRequest schema operationName subs document =
case Transform.document schema operationName subs document of case Transform.document schema operationName subs document of
Left queryError -> pure $ singleError $ Transform.queryError queryError Left queryError -> pure $ singleError $ Transform.queryError queryError
Right (Transform.Document rootObjectType operation) Right (Transform.Document types' rootObjectType operation)
| (AST.Core.Query _ fields) <- operation -> | (Transform.Query _ fields) <- operation ->
executeOperation rootObjectType fields executeOperation types' rootObjectType fields
| (AST.Core.Mutation _ fields) <- operation -> | (Transform.Mutation _ fields) <- operation ->
executeOperation rootObjectType fields executeOperation types' rootObjectType fields
-- This is actually executeMutation, but we don't distinguish between queries -- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet. -- and mutations yet.
executeOperation :: Monad m executeOperation :: Monad m
=> Out.ObjectType m => HashMap Name (Type m)
-> Seq AST.Core.Selection -> Out.ObjectType m
-> Seq (Transform.Selection m)
-> m Aeson.Value -> m Aeson.Value
executeOperation (Out.ObjectType _ _ _ objectFields) fields executeOperation types' objectType fields =
= runCollectErrs runCollectErrs types' $ Schema.resolve Null objectType fields
$ flip Schema.resolve fields
$ fmap getResolver
$ objectFields
where
getResolver (Out.Field _ _ _ resolver) = resolver

61
src/Language/GraphQL/Execute/Coerce.hs
View File

@ -16,7 +16,6 @@ import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import Data.Scientific (toBoundedInteger, toRealFloat) import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST.Document (Name) import Language.GraphQL.AST.Document (Name)
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import Language.GraphQL.Schema
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
-- | Since variables are passed separately from the query, in an independent -- | Since variables are passed separately from the query, in an independent
@ -46,26 +45,26 @@ class VariableValue a where
coerceVariableValue coerceVariableValue
:: In.Type -- ^ Expected type (variable type given in the query). :: In.Type -- ^ Expected type (variable type given in the query).
-> a -- ^ Variable value being coerced. -> a -- ^ Variable value being coerced.
-> Maybe In.Value -- ^ Coerced value on success, 'Nothing' otherwise. -> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise.
instance VariableValue Aeson.Value where instance VariableValue Aeson.Value where
coerceVariableValue _ Aeson.Null = Just In.Null coerceVariableValue _ Aeson.Null = Just Null
coerceVariableValue (In.ScalarBaseType scalarType) value coerceVariableValue (In.ScalarBaseType scalarType) value
| (Aeson.String stringValue) <- value = Just $ In.String stringValue | (Aeson.String stringValue) <- value = Just $ String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ In.Boolean booleanValue | (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue
| (Aeson.Number numberValue) <- value | (Aeson.Number numberValue) <- value
, (ScalarType "Float" _) <- scalarType = , (ScalarType "Float" _) <- scalarType =
Just $ In.Float $ toRealFloat numberValue Just $ Float $ toRealFloat numberValue
| (Aeson.Number numberValue) <- value = -- ID or Int | (Aeson.Number numberValue) <- value = -- ID or Int
In.Int <$> toBoundedInteger numberValue Int <$> toBoundedInteger numberValue
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) = coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
Just $ In.Enum stringValue Just $ Enum stringValue
coerceVariableValue (In.InputObjectBaseType objectType) value coerceVariableValue (In.InputObjectBaseType objectType) value
| (Aeson.Object objectValue) <- value = do | (Aeson.Object objectValue) <- value = do
let (In.InputObjectType _ _ inputFields) = objectType let (In.InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue if HashMap.null newObjectValue
then Just $ In.Object resultMap then Just $ Object resultMap
else Nothing else Nothing
where where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
@ -81,7 +80,7 @@ instance VariableValue Aeson.Value where
pure (newObjectValue, insert coerced) pure (newObjectValue, insert coerced)
Nothing -> Just (objectValue, resultMap) Nothing -> Just (objectValue, resultMap)
coerceVariableValue (In.ListBaseType listType) value coerceVariableValue (In.ListBaseType listType) value
| (Aeson.Array arrayValue) <- value = In.List | (Aeson.Array arrayValue) <- value = List
<$> foldr foldVector (Just []) arrayValue <$> foldr foldVector (Just []) arrayValue
| otherwise = coerceVariableValue listType value | otherwise = coerceVariableValue listType value
where where
@ -95,7 +94,7 @@ instance VariableValue Aeson.Value where
-- corresponding types. -- corresponding types.
coerceInputLiterals coerceInputLiterals
:: HashMap Name In.Type :: HashMap Name In.Type
-> HashMap Name In.Value -> HashMap Name Value
-> Maybe Subs -> Maybe Subs
coerceInputLiterals variableTypes variableValues = coerceInputLiterals variableTypes variableValues =
foldWithKey operator variableTypes foldWithKey operator variableTypes
@ -105,34 +104,34 @@ coerceInputLiterals variableTypes variableValues =
<$> (lookupVariable variableName >>= coerceInputLiteral variableType) <$> (lookupVariable variableName >>= coerceInputLiteral variableType)
<*> resultMap <*> resultMap
coerceInputLiteral (In.NamedScalarType type') value coerceInputLiteral (In.NamedScalarType type') value
| (In.String stringValue) <- value | (String stringValue) <- value
, (ScalarType "String" _) <- type' = Just $ In.String stringValue , (ScalarType "String" _) <- type' = Just $ String stringValue
| (In.Boolean booleanValue) <- value | (Boolean booleanValue) <- value
, (ScalarType "Boolean" _) <- type' = Just $ In.Boolean booleanValue , (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue
| (In.Int intValue) <- value | (Int intValue) <- value
, (ScalarType "Int" _) <- type' = Just $ In.Int intValue , (ScalarType "Int" _) <- type' = Just $ Int intValue
| (In.Float floatValue) <- value | (Float floatValue) <- value
, (ScalarType "Float" _) <- type' = Just $ In.Float floatValue , (ScalarType "Float" _) <- type' = Just $ Float floatValue
| (In.Int intValue) <- value | (Int intValue) <- value
, (ScalarType "Float" _) <- type' = , (ScalarType "Float" _) <- type' =
Just $ In.Float $ fromIntegral intValue Just $ Float $ fromIntegral intValue
| (In.String stringValue) <- value | (String stringValue) <- value
, (ScalarType "ID" _) <- type' = Just $ In.String stringValue , (ScalarType "ID" _) <- type' = Just $ String stringValue
| (In.Int intValue) <- value | (Int intValue) <- value
, (ScalarType "ID" _) <- type' = Just $ decimal intValue , (ScalarType "ID" _) <- type' = Just $ decimal intValue
coerceInputLiteral (In.NamedEnumType type') (In.Enum enumValue) coerceInputLiteral (In.NamedEnumType type') (Enum enumValue)
| member enumValue type' = Just $ In.Enum enumValue | member enumValue type' = Just $ Enum enumValue
coerceInputLiteral (In.NamedInputObjectType type') (In.Object _) = coerceInputLiteral (In.NamedInputObjectType type') (Object _) =
let (In.InputObjectType _ _ inputFields) = type' let (In.InputObjectType _ _ inputFields) = type'
in In.Object <$> foldWithKey matchFieldValues inputFields in Object <$> foldWithKey matchFieldValues inputFields
coerceInputLiteral _ _ = Nothing coerceInputLiteral _ _ = Nothing
member value (EnumType _ _ members) = Set.member value members member value (EnumType _ _ members) = Set.member value members
matchFieldValues fieldName (In.InputField _ type' defaultValue) resultMap = matchFieldValues fieldName (In.InputField _ type' defaultValue) resultMap =
case lookupVariable fieldName of case lookupVariable fieldName of
Just In.Null Just Null
| In.isNonNullType type' -> Nothing | In.isNonNullType type' -> Nothing
| otherwise -> | otherwise ->
HashMap.insert fieldName In.Null <$> resultMap HashMap.insert fieldName Null <$> resultMap
Just variableValue -> HashMap.insert fieldName Just variableValue -> HashMap.insert fieldName
<$> coerceInputLiteral type' variableValue <$> coerceInputLiteral type' variableValue
<*> resultMap <*> resultMap
@ -144,7 +143,7 @@ coerceInputLiterals variableTypes variableValues =
| otherwise -> resultMap | otherwise -> resultMap
lookupVariable = flip HashMap.lookup variableValues lookupVariable = flip HashMap.lookup variableValues
foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty) foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty)
decimal = In.String decimal = String
. Text.Lazy.toStrict . Text.Lazy.toStrict
. Text.Builder.toLazyText . Text.Builder.toLazyText
. Text.Builder.decimal . Text.Builder.decimal

58
src/Language/GraphQL/Execute/Execution.hs Normal file
View File

@ -0,0 +1,58 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Execute.Execution
( aliasOrName
, collectFields
) where
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Execute.Transform
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Selection m)
-> Map Name (Seq (Field m))
collectFields objectType = foldl forEach Map.empty
where
forEach groupedFields (SelectionField field) =
let responseKey = aliasOrName field
in Map.insertWith (<>) responseKey (Seq.singleton field) groupedFields
forEach groupedFields (SelectionFragment selectionFragment)
| Fragment fragmentType fragmentSelectionSet <- selectionFragment
, doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
| otherwise = groupedFields
aliasOrName :: forall m. Field m -> Name
aliasOrName (Field alias name _ _) = fromMaybe name alias
doesFragmentTypeApply :: forall m
. CompositeType m
-> Out.ObjectType m
-> Bool
doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
let Out.ObjectType fragmentName _ _ _ = fragmentType
Out.ObjectType objectName _ _ _ = objectType
in fragmentName == objectName
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
let Out.ObjectType _ _ interfaces _ = objectType
in foldr instanceOf False interfaces
where
instanceOf (Out.InterfaceType that _ interfaces _) acc =
let Out.InterfaceType this _ _ _ = fragmentType
in acc || foldr instanceOf (this == that) interfaces
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
let Out.UnionType _ _ members = fragmentType
in foldr instanceOf False members
where
instanceOf (Out.ObjectType that _ _ _) acc =
let Out.ObjectType this _ _ _ = objectType
in acc || this == that

214
src/Language/GraphQL/Execute/Transform.hs
View File

@ -12,12 +12,17 @@
-- replaced by the selection set they represent. Invalid (recursive and -- replaced by the selection set they represent. Invalid (recursive and
-- non-existing) fragments are skipped. The most fragments are inlined, so the -- non-existing) fragments are skipped. The most fragments are inlined, so the
-- executor doesn't have to perform additional lookups later. -- 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 -- This module is also responsible for smaller rewrites that touch only parts of
-- the original AST. -- the original AST.
module Language.GraphQL.Execute.Transform module Language.GraphQL.Execute.Transform
( Document(..) ( Document(..)
, Fragment(..)
, QueryError(..) , QueryError(..)
, Operation(..)
, Selection(..)
, Field(..)
, document , document
, queryError , queryError
) where ) where
@ -36,26 +41,48 @@ import Data.Sequence (Seq, (<|), (><))
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.AST.Core as Core import Language.GraphQL.AST.Core
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Directive as Directive import qualified Language.GraphQL.Type.Directive as Directive
import Language.GraphQL.Type.Definition (Subs, Value(..))
import qualified Language.GraphQL.AST.Core as Core
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Directive as Core
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
-- | Associates a fragment name with a list of 'Core.Field's. -- | Associates a fragment name with a list of 'Core.Field's.
data Replacement m = Replacement data Replacement m = Replacement
{ fragments :: HashMap Core.Name Core.Fragment { fragments :: HashMap Full.Name (Fragment m)
, fragmentDefinitions :: FragmentDefinitions , fragmentDefinitions :: FragmentDefinitions
, variableValues :: Schema.Subs , variableValues :: Subs
, types :: HashMap Full.Name (Type m) , types :: HashMap Full.Name (Type m)
} }
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
-- | 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 Arguments (Seq (Selection m))
-- | Contains the operation to be executed along with its root type. -- | Contains the operation to be executed along with its root type.
data Document m = Document (Out.ObjectType m) Core.Operation data Document m = Document
(HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
data OperationDefinition = OperationDefinition data OperationDefinition = OperationDefinition
Full.OperationType Full.OperationType
@ -131,7 +158,7 @@ coerceVariableValues :: VariableValue a
. HashMap Full.Name (Type m) . HashMap Full.Name (Type m)
-> OperationDefinition -> OperationDefinition
-> HashMap.HashMap Full.Name a -> HashMap.HashMap Full.Name a
-> Either QueryError Schema.Subs -> Either QueryError Subs
coerceVariableValues types operationDefinition variableValues' = coerceVariableValues types operationDefinition variableValues' =
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
in maybe (Left CoercionError) Right in maybe (Left CoercionError) Right
@ -149,23 +176,23 @@ coerceVariableValues types operationDefinition variableValues' =
<*> coercedValues <*> coercedValues
choose Nothing defaultValue variableType choose Nothing defaultValue variableType
| Just _ <- defaultValue = defaultValue | Just _ <- defaultValue = defaultValue
| not (In.isNonNullType variableType) = Just In.Null | not (In.isNonNullType variableType) = Just Null
choose (Just value') _ variableType choose (Just value') _ variableType
| Just coercedValue <- coerceVariableValue variableType value' | Just coercedValue <- coerceVariableValue variableType value'
, not (In.isNonNullType variableType) || coercedValue /= In.Null = , not (In.isNonNullType variableType) || coercedValue /= Null =
Just coercedValue Just coercedValue
choose _ _ _ = Nothing choose _ _ _ = Nothing
constValue :: Full.ConstValue -> In.Value constValue :: Full.ConstValue -> Value
constValue (Full.ConstInt i) = In.Int i constValue (Full.ConstInt i) = Int i
constValue (Full.ConstFloat f) = In.Float f constValue (Full.ConstFloat f) = Float f
constValue (Full.ConstString x) = In.String x constValue (Full.ConstString x) = String x
constValue (Full.ConstBoolean b) = In.Boolean b constValue (Full.ConstBoolean b) = Boolean b
constValue Full.ConstNull = In.Null constValue Full.ConstNull = Null
constValue (Full.ConstEnum e) = In.Enum e constValue (Full.ConstEnum e) = Enum e
constValue (Full.ConstList l) = In.List $ constValue <$> l constValue (Full.ConstList l) = List $ constValue <$> l
constValue (Full.ConstObject o) = constValue (Full.ConstObject o) =
In.Object $ HashMap.fromList $ constObjectField <$> o Object $ HashMap.fromList $ constObjectField <$> o
where where
constObjectField (Full.ObjectField key value') = (key, constValue value') constObjectField (Full.ObjectField key value') = (key, constValue value')
@ -193,12 +220,12 @@ document schema operationName subs ast = do
} }
case chosenOperation of case chosenOperation of
OperationDefinition Full.Query _ _ _ _ -> OperationDefinition Full.Query _ _ _ _ ->
pure $ Document (query schema) pure $ Document referencedTypes (query schema)
$ operation (query schema) chosenOperation replacement $ operation chosenOperation replacement
OperationDefinition Full.Mutation _ _ _ _ OperationDefinition Full.Mutation _ _ _ _
| Just mutationType <- mutation schema -> | Just mutationType <- mutation schema ->
pure $ Document mutationType pure $ Document referencedTypes mutationType
$ operation mutationType chosenOperation replacement $ operation chosenOperation replacement
_ -> Left UnsupportedRootOperation _ -> Left UnsupportedRootOperation
defragment defragment
@ -227,72 +254,73 @@ defragment ast =
-- * Operation -- * Operation
operation :: forall m operation :: OperationDefinition -> Replacement m -> Operation m
. Out.ObjectType m operation operationDefinition replacement
-> OperationDefinition
-> Replacement m
-> Core.Operation
operation rootType operationDefinition replacement
= runIdentity = runIdentity
$ evalStateT (collectFragments rootType >> transform operationDefinition) replacement $ evalStateT (collectFragments >> transform operationDefinition) replacement
where where
transform (OperationDefinition Full.Query name _ _ sels) = transform (OperationDefinition Full.Query name _ _ sels) =
Core.Query name <$> appendSelection sels rootType Query name <$> appendSelection sels
transform (OperationDefinition Full.Mutation name _ _ sels) = transform (OperationDefinition Full.Mutation name _ _ sels) =
Core.Mutation name <$> appendSelection sels rootType Mutation name <$> appendSelection sels
-- * Selection -- * Selection
selection :: forall m selection
. Full.Selection :: Full.Selection
-> Out.ObjectType m -> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
-> State (Replacement m) (Either (Seq Core.Selection) Core.Selection) selection (Full.Field alias name arguments' directives' selections) =
selection (Full.Field alias name arguments' directives' selections) objectType = maybe (Left mempty) (Right . SelectionField) <$> do
maybe (Left mempty) (Right . Core.SelectionField) <$> do
fieldArguments <- arguments arguments' fieldArguments <- arguments arguments'
fieldSelections <- appendSelection selections objectType fieldSelections <- appendSelection selections
fieldDirectives <- Directive.selection <$> directives directives' fieldDirectives <- Directive.selection <$> directives directives'
let field' = Core.Field alias name fieldArguments fieldSelections let field' = Field alias name fieldArguments fieldSelections
pure $ field' <$ fieldDirectives pure $ field' <$ fieldDirectives
selection (Full.FragmentSpread name directives') objectType = selection (Full.FragmentSpread name directives') =
maybe (Left mempty) (Right . Core.SelectionFragment) <$> do maybe (Left mempty) (Right . SelectionFragment) <$> do
spreadDirectives <- Directive.selection <$> directives directives' spreadDirectives <- Directive.selection <$> directives directives'
fragments' <- gets fragments fragments' <- gets fragments
fragmentDefinitions' <- gets fragmentDefinitions fragmentDefinitions' <- gets fragmentDefinitions
case HashMap.lookup name fragments' of case HashMap.lookup name fragments' of
Just definition -> lift $ pure $ definition <$ spreadDirectives Just definition -> lift $ pure $ definition <$ spreadDirectives
Nothing -> case HashMap.lookup name fragmentDefinitions' of Nothing
Just definition -> do | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
fragment <- fragmentDefinition definition objectType fragDef <- fragmentDefinition definition
lift $ pure $ fragment <$ spreadDirectives case fragDef of
Nothing -> lift $ pure Nothing Just fragment -> lift $ pure $ fragment <$ spreadDirectives
selection (Full.InlineFragment type' directives' selections) objectType = do _ -> lift $ pure Nothing
| otherwise -> lift $ pure Nothing
selection (Full.InlineFragment type' directives' selections) = do
fragmentDirectives <- Directive.selection <$> directives directives' fragmentDirectives <- Directive.selection <$> directives directives'
case fragmentDirectives of case fragmentDirectives of
Nothing -> pure $ Left mempty Nothing -> pure $ Left mempty
_ -> do _ -> do
fragmentSelectionSet <- appendSelection selections objectType 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 where
selectionFragment typeName = Right selectionFragment typeName = Right
. Core.SelectionFragment . SelectionFragment
. Core.Fragment typeName . Fragment typeName
appendSelection :: Traversable t appendSelection :: Traversable t
=> forall m => t Full.Selection
. t Full.Selection -> State (Replacement m) (Seq (Selection m))
-> Out.ObjectType m appendSelection = foldM go mempty
-> State (Replacement m) (Seq Core.Selection)
appendSelection selectionSet objectType = foldM go mempty selectionSet
where where
go acc sel = append acc <$> selection sel objectType go acc sel = append acc <$> selection sel
append acc (Left list) = list >< acc append acc (Left list) = list >< acc
append acc (Right one) = one <| acc append acc (Right one) = one <| acc
directives :: forall m directives :: [Full.Directive] -> State (Replacement m) [Core.Directive]
. [Full.Directive]
-> State (Replacement m) [Core.Directive]
directives = traverse directive directives = traverse directive
where where
directive (Full.Directive directiveName directiveArguments) = directive (Full.Directive directiveName directiveArguments) =
@ -301,24 +329,40 @@ directives = traverse directive
-- * Fragment replacement -- * Fragment replacement
-- | Extract fragment definitions into a single 'HashMap'. -- | Extract fragment definitions into a single 'HashMap'.
collectFragments :: forall m. Out.ObjectType m -> State (Replacement m) () collectFragments :: State (Replacement m) ()
collectFragments objectType = do collectFragments = do
fragDefs <- gets fragmentDefinitions fragDefs <- gets fragmentDefinitions
let nextValue = head $ HashMap.elems fragDefs let nextValue = head $ HashMap.elems fragDefs
unless (HashMap.null fragDefs) $ do unless (HashMap.null fragDefs) $ do
_ <- fragmentDefinition nextValue objectType _ <- fragmentDefinition nextValue
collectFragments objectType collectFragments
fragmentDefinition :: forall m lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m))
. Full.FragmentDefinition lookupTypeCondition type' = do
-> Out.ObjectType m types' <- gets types
-> State (Replacement m) Core.Fragment case HashMap.lookup type' types' of
fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType = do 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 modify deleteFragmentDefinition
fragmentSelection <- appendSelection selections objectType fragmentSelection <- appendSelection selections
let newValue = Core.Fragment type' fragmentSelection compositeType <- lookupTypeCondition type'
case compositeType of
Just compositeType' -> do
let newValue = Fragment compositeType' fragmentSelection
modify $ insertFragment newValue modify $ insertFragment newValue
lift $ pure newValue lift $ pure $ Just newValue
_ -> lift $ pure Nothing
where where
deleteFragmentDefinition replacement@Replacement{..} = deleteFragmentDefinition replacement@Replacement{..} =
let newDefinitions = HashMap.delete name fragmentDefinitions let newDefinitions = HashMap.delete name fragmentDefinitions
@ -327,27 +371,27 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType
let newFragments = HashMap.insert name newValue fragments let newFragments = HashMap.insert name newValue fragments
in replacement{ fragments = newFragments } in replacement{ fragments = newFragments }
arguments :: forall m. [Full.Argument] -> State (Replacement m) Core.Arguments arguments :: [Full.Argument] -> State (Replacement m) Core.Arguments
arguments = fmap Core.Arguments . foldM go HashMap.empty arguments = fmap Core.Arguments . foldM go HashMap.empty
where where
go arguments' (Full.Argument name value') = do go arguments' (Full.Argument name value') = do
substitutedValue <- value value' substitutedValue <- value value'
return $ HashMap.insert name substitutedValue arguments' return $ HashMap.insert name substitutedValue arguments'
value :: forall m. Full.Value -> State (Replacement m) In.Value value :: Full.Value -> State (Replacement m) Value
value (Full.Variable name) = value (Full.Variable name) =
gets $ fromMaybe In.Null . HashMap.lookup name . variableValues gets $ fromMaybe Null . HashMap.lookup name . variableValues
value (Full.Int i) = pure $ In.Int i value (Full.Int i) = pure $ Int i
value (Full.Float f) = pure $ In.Float f value (Full.Float f) = pure $ Float f
value (Full.String x) = pure $ In.String x value (Full.String x) = pure $ String x
value (Full.Boolean b) = pure $ In.Boolean b value (Full.Boolean b) = pure $ Boolean b
value Full.Null = pure In.Null value Full.Null = pure Null
value (Full.Enum e) = pure $ In.Enum e value (Full.Enum e) = pure $ Enum e
value (Full.List l) = In.List <$> traverse value l value (Full.List l) = List <$> traverse value l
value (Full.Object o) = value (Full.Object o) =
In.Object . HashMap.fromList <$> traverse objectField o Object . HashMap.fromList <$> traverse objectField o
objectField :: forall m objectField
. Full.ObjectField Full.Value :: Full.ObjectField Full.Value
-> State (Replacement m) (Core.Name, In.Value) -> State (Replacement m) (Full.Name, Value)
objectField (Full.ObjectField name value') = (name,) <$> value value' objectField (Full.ObjectField name value') = (name,) <$> value value'

133
src/Language/GraphQL/Schema.hs
View File

@ -5,27 +5,24 @@
-- functions for defining and manipulating schemas. -- functions for defining and manipulating schemas.
module Language.GraphQL.Schema module Language.GraphQL.Schema
( Resolver(..) ( Resolver(..)
, Subs
, object
, resolve , resolve
, resolversToMap
) where ) where
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (fold, toList)
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq) import qualified Data.Map.Strict as Map
import Data.Sequence (Seq(..))
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as Text
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Execute.Execution
import Language.GraphQL.Execute.Transform
import Language.GraphQL.Trans import Language.GraphQL.Trans
import qualified Language.GraphQL.Type.In as In import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
@ -35,82 +32,74 @@ import qualified Language.GraphQL.Type.Out as Out
-- Resolving a field can result in a leaf value or an object, which is -- 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 -- represented as a list of nested resolvers, used to resolve the fields of that
-- object. -- object.
data Resolver m = Resolver Name (ActionT m (Out.Value m)) data Resolver m = Resolver Name (ActionT m Value)
-- | Converts resolvers to a map. resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
resolversToMap :: (Foldable f, Functor f) resolveFieldValue result (Field _ _ args _) =
=> forall m flip runReaderT (Context {arguments=args, values=result})
. f (Resolver m)
-> HashMap Text (ActionT m (Out.Value m))
resolversToMap = HashMap.fromList . toList . fmap toKV
where
toKV (Resolver name r) = (name, r)
-- | 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 In.Value
-- | Create a new 'Resolver' with the given 'Name' from the given
-- Resolver's.
object :: Monad m => [Resolver m] -> Out.Value m
object = Out.Object . resolversToMap
resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
resolveFieldValue field@(Field _ _ args _) =
flip runReaderT (Context {arguments=args, info=field})
. runExceptT . runExceptT
. runActionT . runActionT
withField :: Monad m executeField :: Monad m
=> Field => Value
-> ActionT m (Out.Value m) -> Out.Field m
-> CollectErrsT m Aeson.Object -> Field m
withField field resolver = do -> CollectErrsT m Aeson.Value
answer <- lift $ resolveFieldValue field resolver executeField prev (Out.Field _ fieldType _ resolver) field = do
answer <- lift $ resolveFieldValue prev field resolver
case answer of case answer of
Right result -> HashMap.singleton (aliasOrName field) Right result -> completeValue fieldType field result
<$> toJSON field result Left errorMessage -> errmsg errorMessage
Left errorMessage -> errmsg field errorMessage
toJSON :: Monad m => Field -> Out.Value m -> CollectErrsT m Aeson.Value completeValue :: Monad m
toJSON _ Out.Null = pure Aeson.Null => Out.Type m
toJSON _ (Out.Int integer) = pure $ Aeson.toJSON integer -> Field m
toJSON _ (Out.Boolean boolean) = pure $ Aeson.Bool boolean -> Value
toJSON _ (Out.Float float) = pure $ Aeson.toJSON float -> CollectErrsT m Aeson.Value
toJSON _ (Out.Enum enum) = pure $ Aeson.String enum completeValue _ _ Null = pure Aeson.Null
toJSON _ (Out.String string) = pure $ Aeson.String string completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
toJSON field (Out.List list) = Aeson.toJSON <$> traverse (toJSON field) list completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
toJSON (Field _ _ _ seqSelection) (Out.Object map') = completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
map' `resolve` seqSelection completeValue _ _ (Enum enum) = pure $ Aeson.String enum
completeValue _ _ (String string') = pure $ Aeson.String string'
completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
resolve result objectType seqSelection
completeValue (Out.ListBaseType listType) selectionField (List list) =
Aeson.toJSON <$> traverse (completeValue listType selectionField) list
completeValue _ _ _ = errmsg "Value completion failed."
errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value) errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
errmsg field errorMessage = do errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
addErrMsg errorMessage
pure $ HashMap.singleton (aliasOrName field) Aeson.Null
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- | 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 -- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information. -- resolved 'Field', or a null value and error information.
resolve :: Monad m resolve :: Monad m -- executeSelectionSet
=> HashMap Text (ActionT m (Out.Value m)) => Value
-> Seq Selection -> Out.ObjectType m
-> Seq (Selection m)
-> CollectErrsT m Aeson.Value -> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers resolve result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
resolvedValues <- Map.traverseMaybeWithKey forEach
$ collectFields objectType selectionSet
pure $ Aeson.toJSON resolvedValues
where where
forEach _responseKey (field :<| _) =
tryResolvers field >>= lift . pure . pure
forEach _ _ = pure Nothing
lookupResolver = flip HashMap.lookup resolvers lookupResolver = flip HashMap.lookup resolvers
tryResolvers (SelectionField fld@(Field _ name _ _)) tryResolvers fld@(Field _ name _ _)
| (Just resolver) <- lookupResolver name = withField fld resolver | Just typeField <- lookupResolver name =
| otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."] executeField result typeField fld
tryResolvers (SelectionFragment (Fragment typeCondition selections')) | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
| Just resolver <- lookupResolver "__typename" = do {-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections'))
let fakeField = Field Nothing "__typename" mempty mempty | Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do
that <- lift $ resolveFieldValue fakeField resolver let fakeField = Out.Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue result fakeField resolver
case that of case that of
Right (Out.String typeCondition') Right (String typeCondition')
| typeCondition' == typeCondition -> | (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition
, typeCondition' == n ->
fmap fold . traverse tryResolvers $ selections' fmap fold . traverse tryResolvers $ selections'
_ -> pure mempty _ -> pure mempty
| otherwise = fmap fold . traverse tryResolvers $ selections' | otherwise = fmap fold . traverse tryResolvers $ selections'-}
aliasOrName :: Field -> Text
aliasOrName (Field alias name _ _) = fromMaybe name alias

14
src/Language/GraphQL/Trans.hs
View File

@ -1,8 +1,8 @@
-- | Monad transformer stack used by the @GraphQL@ resolvers. -- | Monad transformer stack used by the @GraphQL@ resolvers.
module Language.GraphQL.Trans module Language.GraphQL.Trans
( ActionT(..) ( argument
, ActionT(..)
, Context(..) , Context(..)
, argument
) where ) where
import Control.Applicative (Alternative(..)) import Control.Applicative (Alternative(..))
@ -15,13 +15,13 @@ import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Core
import qualified Language.GraphQL.Type.In as In import Language.GraphQL.Type.Definition
import Prelude hiding (lookup) import Prelude hiding (lookup)
-- | Resolution context holds resolver arguments. -- | Resolution context holds resolver arguments.
data Context = Context data Context = Context
{ arguments :: Arguments { arguments :: Arguments
, info :: Field , values :: Value
} }
-- | Monad transformer stack used by the resolvers to provide error handling -- | Monad transformer stack used by the resolvers to provide error handling
@ -56,11 +56,11 @@ instance Monad m => MonadPlus (ActionT m) where
mplus = (<|>) mplus = (<|>)
-- | Retrieves an argument by its name. If the argument with this name couldn't -- | Retrieves an argument by its name. If the argument with this name couldn't
-- be found, returns 'In.Null' (i.e. the argument is assumed to -- be found, returns 'Null' (i.e. the argument is assumed to
-- be optional then). -- be optional then).
argument :: Monad m => Name -> ActionT m In.Value argument :: Monad m => Name -> ActionT m Value
argument argumentName = do argument argumentName = do
argumentValue <- ActionT $ lift $ asks $ lookup . arguments argumentValue <- ActionT $ lift $ asks $ lookup . arguments
pure $ fromMaybe In.Null argumentValue pure $ fromMaybe Null argumentValue
where where
lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap

24
src/Language/GraphQL/Type/Definition.hs
View File

@ -4,6 +4,8 @@
module Language.GraphQL.Type.Definition module Language.GraphQL.Type.Definition
( EnumType(..) ( EnumType(..)
, ScalarType(..) , ScalarType(..)
, Subs
, Value(..)
, boolean , boolean
, float , float
, id , id
@ -11,11 +13,33 @@ module Language.GraphQL.Type.Definition
, string , string
) where ) where
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import Data.Set (Set) import Data.Set (Set)
import Data.String (IsString(..))
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Document (Name) import Language.GraphQL.AST.Document (Name)
import Prelude hiding (id) 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. -- | Scalar type definition.
-- --
-- The leaf values of any request and input values to arguments are Scalars (or -- The leaf values of any request and input values to arguments are Scalars (or

13
src/Language/GraphQL/Type/Directive.hs
View File

@ -1,12 +1,17 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Type.Directive module Language.GraphQL.Type.Directive
( selection ( Directive(..)
, selection
) where ) where
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Core
import qualified Language.GraphQL.Type.In as In import Language.GraphQL.Type.Definition
-- | Directive.
data Directive = Directive Name Arguments
deriving (Eq, Show)
-- | Directive processing status. -- | Directive processing status.
data Status data Status
@ -37,7 +42,7 @@ skip = handle skip'
where where
skip' directive'@(Directive "skip" (Arguments arguments)) = skip' directive'@(Directive "skip" (Arguments arguments)) =
case HashMap.lookup "if" arguments of case HashMap.lookup "if" arguments of
(Just (In.Boolean True)) -> Skip (Just (Boolean True)) -> Skip
_ -> Include directive' _ -> Include directive'
skip' directive' = Continue directive' skip' directive' = Continue directive'
@ -46,6 +51,6 @@ include = handle include'
where where
include' directive'@(Directive "include" (Arguments arguments)) = include' directive'@(Directive "include" (Arguments arguments)) =
case HashMap.lookup "if" arguments of case HashMap.lookup "if" arguments of
(Just (In.Boolean True)) -> Include directive' (Just (Boolean True)) -> Include directive'
_ -> Skip _ -> Skip
include' directive' = Continue directive' include' directive' = Continue directive'

22
src/Language/GraphQL/Type/In.hs
View File

@ -10,7 +10,6 @@ module Language.GraphQL.Type.In
, InputField(..) , InputField(..)
, InputObjectType(..) , InputObjectType(..)
, Type(..) , Type(..)
, Value(..)
, isNonNullType , isNonNullType
, pattern EnumBaseType , pattern EnumBaseType
, pattern ListBaseType , pattern ListBaseType
@ -19,8 +18,6 @@ module Language.GraphQL.Type.In
) where ) where
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Int (Int32)
import Data.String (IsString(..))
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Document (Name) import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
@ -36,6 +33,10 @@ data InputObjectType = InputObjectType
Name (Maybe Text) (HashMap Name InputField) Name (Maybe Text) (HashMap Name InputField)
-- | These types may be used as input types for arguments and directives. -- | 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 data Type
= NamedScalarType ScalarType = NamedScalarType ScalarType
| NamedEnumType EnumType | NamedEnumType EnumType
@ -46,21 +47,6 @@ data Type
| NonNullInputObjectType InputObjectType | NonNullInputObjectType InputObjectType
| NonNullListType Type | NonNullListType Type
-- | 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
-- | Field argument definition. -- | Field argument definition.
data Argument = Argument (Maybe Text) Type (Maybe Value) data Argument = Argument (Maybe Text) Type (Maybe Value)

56
src/Language/GraphQL/Type/Out.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
@ -13,7 +12,6 @@ module Language.GraphQL.Type.Out
, ObjectType(..) , ObjectType(..)
, Type(..) , Type(..)
, UnionType(..) , UnionType(..)
, Value(..)
, isNonNullType , isNonNullType
, pattern EnumBaseType , pattern EnumBaseType
, pattern InterfaceBaseType , pattern InterfaceBaseType
@ -24,12 +22,8 @@ module Language.GraphQL.Type.Out
) where ) where
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Int (Int32)
import Data.String (IsString(..))
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import Language.GraphQL.AST.Core
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Trans import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
@ -60,9 +54,13 @@ data Field m = Field
(Maybe Text) -- ^ Description. (Maybe Text) -- ^ Description.
(Type m) -- ^ Field type. (Type m) -- ^ Field type.
(HashMap Name In.Argument) -- ^ Arguments. (HashMap Name In.Argument) -- ^ Arguments.
(ActionT m (Value m)) -- ^ Resolver. (ActionT m Value) -- ^ Resolver.
-- | These types may be used as output types as the result of fields. -- | 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 data Type m
= NamedScalarType ScalarType = NamedScalarType ScalarType
| NamedEnumType EnumType | NamedEnumType EnumType
@ -77,48 +75,6 @@ data Type m
| NonNullUnionType (UnionType m) | NonNullUnionType (UnionType m)
| NonNullListType (Type m) | NonNullListType (Type m)
-- | 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 'Value' 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 Value m
= Int Int32
| Float Double
| String Text
| Boolean Bool
| Null
| Enum Name
| List [Value m] -- ^ Arbitrary nested list.
| Object (HashMap Name (ActionT m (Value m)))
instance IsString (Value m) where
fromString = String . fromString
instance Show (Value m) where
show (Int integer) = "Int " ++ show integer
show (Float float') = "Float " ++ show float'
show (String text) = Text.unpack $ "String " <> text
show (Boolean True) = "Boolean True"
show (Boolean False) = "Boolean False"
show Null = "Null"
show (Enum enum) = Text.unpack $ "Enum " <> enum
show (List list) = show list
show (Object object) = Text.unpack
$ "Object [" <> Text.intercalate ", " (HashMap.keys object) <> "]"
instance Eq (Value m) where
(Int this) == (Int that) = this == that
(Float this) == (Float that) = this == that
(String this) == (String that) = this == that
(Boolean this) == (Boolean that) = this == that
(Enum this) == (Enum that) = this == that
(List this) == (List that) = this == that
(Object this) == (Object that) = HashMap.keys this == HashMap.keys that
_ == _ = False
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'. -- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
pattern ScalarBaseType :: forall m. ScalarType -> Type m pattern ScalarBaseType :: forall m. ScalarType -> Type m
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType) pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)

11
src/Language/GraphQL/Type/Schema.hs
View File

@ -2,14 +2,15 @@
-- | Schema Definition. -- | Schema Definition.
module Language.GraphQL.Type.Schema module Language.GraphQL.Type.Schema
( Schema(..) ( CompositeType(..)
, Schema(..)
, Type(..) , Type(..)
, collectReferencedTypes , collectReferencedTypes
) where ) where
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL.AST.Core (Name) import Language.GraphQL.AST.Document (Name)
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
@ -23,6 +24,12 @@ data Type m
| InterfaceType (Out.InterfaceType m) | InterfaceType (Out.InterfaceType m)
| UnionType (Out.UnionType m) | UnionType (Out.UnionType m)
-- | 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)
-- | A Schema is created by supplying the root types of each type of operation, -- | 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 -- query and mutation (optional). A schema definition is then supplied to the
-- validator and executor. -- validator and executor.

2
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: lts-15.13 resolver: lts-15.14
packages: packages:
- . - .

37
tests/Language/GraphQL/Execute/CoerceSpec.hs
View File

@ -11,9 +11,8 @@ import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (isNothing) import Data.Maybe (isNothing)
import Data.Scientific (scientific) import Data.Scientific (scientific)
import qualified Data.Set as Set import qualified Data.Set as Set
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Schema
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import Prelude hiding (id) import Prelude hiding (id)
@ -23,12 +22,12 @@ direction :: EnumType
direction = EnumType "Direction" Nothing direction = EnumType "Direction" Nothing
$ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"] $ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"]
coerceInputLiteral :: In.Type -> In.Value -> Maybe Subs coerceInputLiteral :: In.Type -> Value -> Maybe Subs
coerceInputLiteral input value = coerceInputLiterals coerceInputLiteral input value = coerceInputLiterals
(HashMap.singleton "variableName" input) (HashMap.singleton "variableName" input)
(HashMap.singleton "variableName" value) (HashMap.singleton "variableName" value)
lookupActual :: Maybe (HashMap Name In.Value) -> Maybe In.Value lookupActual :: Maybe (HashMap Name Value) -> Maybe Value
lookupActual = (HashMap.lookup "variableName" =<<) lookupActual = (HashMap.lookup "variableName" =<<)
singletonInputObject :: In.Type singletonInputObject :: In.Type
@ -42,22 +41,22 @@ spec :: Spec
spec = do spec = do
describe "ToGraphQL Aeson" $ do describe "ToGraphQL Aeson" $ do
it "coerces strings" $ it "coerces strings" $
let expected = Just (In.String "asdf") let expected = Just (String "asdf")
actual = coerceVariableValue actual = coerceVariableValue
(In.NamedScalarType string) (Aeson.String "asdf") (In.NamedScalarType string) (Aeson.String "asdf")
in actual `shouldBe` expected in actual `shouldBe` expected
it "coerces non-null strings" $ it "coerces non-null strings" $
let expected = Just (In.String "asdf") let expected = Just (String "asdf")
actual = coerceVariableValue actual = coerceVariableValue
(In.NonNullScalarType string) (Aeson.String "asdf") (In.NonNullScalarType string) (Aeson.String "asdf")
in actual `shouldBe` expected in actual `shouldBe` expected
it "coerces booleans" $ it "coerces booleans" $
let expected = Just (In.Boolean True) let expected = Just (Boolean True)
actual = coerceVariableValue actual = coerceVariableValue
(In.NamedScalarType boolean) (Aeson.Bool True) (In.NamedScalarType boolean) (Aeson.Bool True)
in actual `shouldBe` expected in actual `shouldBe` expected
it "coerces zero to an integer" $ it "coerces zero to an integer" $
let expected = Just (In.Int 0) let expected = Just (Int 0)
actual = coerceVariableValue actual = coerceVariableValue
(In.NamedScalarType int) (Aeson.Number 0) (In.NamedScalarType int) (Aeson.Number 0)
in actual `shouldBe` expected in actual `shouldBe` expected
@ -66,24 +65,24 @@ spec = do
(In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1)) (In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1))
in actual `shouldSatisfy` isNothing in actual `shouldSatisfy` isNothing
it "coerces float numbers" $ it "coerces float numbers" $
let expected = Just (In.Float 1.4) let expected = Just (Float 1.4)
actual = coerceVariableValue actual = coerceVariableValue
(In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1)) (In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1))
in actual `shouldBe` expected in actual `shouldBe` expected
it "coerces IDs" $ it "coerces IDs" $
let expected = Just (In.String "1234") let expected = Just (String "1234")
actual = coerceVariableValue actual = coerceVariableValue
(In.NamedScalarType id) (Aeson.String "1234") (In.NamedScalarType id) (Aeson.String "1234")
in actual `shouldBe` expected in actual `shouldBe` expected
it "coerces input objects" $ it "coerces input objects" $
let actual = coerceVariableValue singletonInputObject let actual = coerceVariableValue singletonInputObject
$ Aeson.object ["field" .= ("asdf" :: Aeson.Value)] $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]
expected = Just $ In.Object $ HashMap.singleton "field" "asdf" expected = Just $ Object $ HashMap.singleton "field" "asdf"
in actual `shouldBe` expected in actual `shouldBe` expected
it "skips the field if it is missing in the variables" $ it "skips the field if it is missing in the variables" $
let actual = coerceVariableValue let actual = coerceVariableValue
singletonInputObject Aeson.emptyObject singletonInputObject Aeson.emptyObject
expected = Just $ In.Object HashMap.empty expected = Just $ Object HashMap.empty
in actual `shouldBe` expected in actual `shouldBe` expected
it "fails if input object value contains extra fields" $ it "fails if input object value contains extra fields" $
let actual = coerceVariableValue singletonInputObject let actual = coerceVariableValue singletonInputObject
@ -95,25 +94,25 @@ spec = do
in actual `shouldSatisfy` isNothing in actual `shouldSatisfy` isNothing
it "preserves null" $ it "preserves null" $
let actual = coerceVariableValue (In.NamedScalarType id) Aeson.Null let actual = coerceVariableValue (In.NamedScalarType id) Aeson.Null
in actual `shouldBe` Just In.Null in actual `shouldBe` Just Null
it "preserves list order" $ it "preserves list order" $
let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"] let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
listType = (In.ListType $ In.NamedScalarType string) listType = (In.ListType $ In.NamedScalarType string)
actual = coerceVariableValue listType list actual = coerceVariableValue listType list
expected = Just $ In.List [In.String "asdf", In.String "qwer"] expected = Just $ List [String "asdf", String "qwer"]
in actual `shouldBe` expected in actual `shouldBe` expected
describe "coerceInputLiterals" $ do describe "coerceInputLiterals" $ do
it "coerces enums" $ it "coerces enums" $
let expected = Just (In.Enum "NORTH") let expected = Just (Enum "NORTH")
actual = coerceInputLiteral actual = coerceInputLiteral
(In.NamedEnumType direction) (In.Enum "NORTH") (In.NamedEnumType direction) (Enum "NORTH")
in lookupActual actual `shouldBe` expected in lookupActual actual `shouldBe` expected
it "fails with non-existing enum value" $ it "fails with non-existing enum value" $
let actual = coerceInputLiteral let actual = coerceInputLiteral
(In.NamedEnumType direction) (In.Enum "NORTH_EAST") (In.NamedEnumType direction) (Enum "NORTH_EAST")
in actual `shouldSatisfy` isNothing in actual `shouldSatisfy` isNothing
it "coerces integers to IDs" $ it "coerces integers to IDs" $
let expected = Just (In.String "1234") let expected = Just (String "1234")
actual = coerceInputLiteral (In.NamedScalarType id) (In.Int 1234) actual = coerceInputLiteral (In.NamedScalarType id) (Int 1234)
in lookupActual actual `shouldBe` expected in lookupActual actual `shouldBe` expected

32
tests/Language/GraphQL/SchemaSpec.hs
View File

@ -1,32 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.SchemaSpec
( spec
) where
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Sequence as Sequence
import Language.GraphQL.AST.Core
import Language.GraphQL.Error
import Language.GraphQL.Schema
import qualified Language.GraphQL.Type.Out as Out
import Test.Hspec (Spec, describe, it, shouldBe)
spec :: Spec
spec =
describe "resolve" $
it "ignores invalid __typename" $ do
let resolver = pure $ object
[ Resolver "field" $ pure $ Out.String "T"
]
schema = HashMap.singleton "__typename" resolver
fields = Sequence.singleton
$ SelectionFragment
$ Fragment "T" Sequence.empty
expected = Aeson.object
[ ("data" , Aeson.emptyObject)
]
actual <- runCollectErrs (resolve schema fields)
actual `shouldBe` expected

7
tests/Language/GraphQL/Type/OutSpec.hs
View File

@ -3,13 +3,12 @@ module Language.GraphQL.Type.OutSpec
( spec ( spec
) where ) where
import Data.Functor.Identity (Identity) import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe)
spec :: Spec spec :: Spec
spec = spec =
describe "Value" $ describe "Value" $
it "supports overloaded strings" $ it "supports overloaded strings" $
let string = "Goldstaub abblasen." :: (Out.Value Identity) let nietzsche = "Goldstaub abblasen." :: Value
in string `shouldBe` Out.String "Goldstaub abblasen." in nietzsche `shouldBe` String "Goldstaub abblasen."

7
tests/Test/DirectiveSpec.hs
View File

@ -4,7 +4,8 @@ module Test.DirectiveSpec
( spec ( spec
) where ) where
import Data.Aeson (Value(..), object, (.=)) import Data.Aeson (object, (.=))
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL import Language.GraphQL
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
@ -16,12 +17,12 @@ import Text.RawString.QQ (r)
experimentalResolver :: Schema IO experimentalResolver :: Schema IO
experimentalResolver = Schema { query = queryType, mutation = Nothing } experimentalResolver = Schema { query = queryType, mutation = Nothing }
where where
resolver = pure $ Out.Int 5 resolver = pure $ Int 5
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField" $ HashMap.singleton "experimentalField"
$ Out.Field Nothing (Out.NamedScalarType int) mempty resolver $ Out.Field Nothing (Out.NamedScalarType int) mempty resolver
emptyObject :: Value emptyObject :: Aeson.Value
emptyObject = object emptyObject = object
[ "data" .= object [] [ "data" .= object []
] ]

80
tests/Test/FragmentSpec.hs
View File

@ -4,11 +4,11 @@ module Test.FragmentSpec
( spec ( spec
) where ) where
import Data.Aeson (Value(..), object, (.=)) import Data.Aeson (object, (.=))
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
@ -21,18 +21,19 @@ import Test.Hspec
) )
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
size :: Schema.Resolver IO size :: (Text, Value)
size = Schema.Resolver "size" $ pure $ Out.String "L" size = ("size", String "L")
circumference :: Schema.Resolver IO circumference :: (Text, Value)
circumference = Schema.Resolver "circumference" $ pure $ Out.Int 60 circumference = ("circumference", Int 60)
garment :: Text -> Schema.Resolver IO garment :: Text -> (Text, Value)
garment typeName = Schema.Resolver "garment" garment typeName =
$ pure $ Schema.object ("garment", Object $ HashMap.fromList
[ if typeName == "Hat" then circumference else size [ if typeName == "Hat" then circumference else size
, Schema.Resolver "__typename" $ pure $ Out.String typeName , ("__typename", String typeName)
] ]
)
inlineQuery :: Text inlineQuery :: Text
inlineQuery = [r|{ inlineQuery = [r|{
@ -46,38 +47,46 @@ inlineQuery = [r|{
} }
}|] }|]
hasErrors :: Value -> Bool hasErrors :: Aeson.Value -> Bool
hasErrors (Object object') = HashMap.member "errors" object' hasErrors (Aeson.Object object') = HashMap.member "errors" object'
hasErrors _ = True hasErrors _ = True
shirtType :: Out.ObjectType IO shirtType :: Out.ObjectType IO
shirtType = Out.ObjectType "Shirt" Nothing [] shirtType = Out.ObjectType "Shirt" Nothing []
$ HashMap.singleton resolverName $ HashMap.fromList
$ Out.Field Nothing (Out.NamedScalarType string) mempty resolve [ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size)
where , ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference)
(Schema.Resolver resolverName resolve) = size , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
]
hatType :: Out.ObjectType IO hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing [] hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.singleton resolverName $ HashMap.fromList
$ Out.Field Nothing (Out.NamedScalarType int) mempty resolve [ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size)
where , ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference)
(Schema.Resolver resolverName resolve) = circumference , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Hat")
]
toSchema :: Schema.Resolver IO -> Schema IO toSchema :: Text -> (Text, Value) -> Schema IO
toSchema (Schema.Resolver resolverName resolve) = Schema toSchema t (_, resolve) = Schema
{ query = queryType, mutation = Nothing } { query = queryType, mutation = Nothing }
where where
unionMember = if resolverName == "Hat" then hatType else shirtType unionMember = if t == "Hat" then hatType else shirtType
queryType = Out.ObjectType "Query" Nothing [] queryType =
$ HashMap.singleton resolverName case t of
$ Out.Field Nothing (Out.NamedObjectType unionMember) mempty resolve "circumference" -> hatType
"size" -> shirtType
_ -> Out.ObjectType "Query" Nothing []
$ HashMap.fromList
[ ("garment", Out.Field Nothing (Out.NamedObjectType unionMember) mempty $ pure resolve)
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
]
spec :: Spec spec :: Spec
spec = do spec = do
describe "Inline fragment executor" $ do describe "Inline fragment executor" $ do
it "chooses the first selection if the type matches" $ do it "chooses the first selection if the type matches" $ do
actual <- graphql (toSchema $ garment "Hat") inlineQuery actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
let expected = object let expected = object
[ "data" .= object [ "data" .= object
[ "garment" .= object [ "garment" .= object
@ -88,7 +97,7 @@ spec = do
in actual `shouldBe` expected in actual `shouldBe` expected
it "chooses the last selection if the type matches" $ do it "chooses the last selection if the type matches" $ do
actual <- graphql (toSchema $ garment "Shirt") inlineQuery actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
let expected = object let expected = object
[ "data" .= object [ "data" .= object
[ "garment" .= object [ "garment" .= object
@ -107,10 +116,9 @@ spec = do
} }
} }
}|] }|]
resolvers = Schema.Resolver "garment" resolvers = ("garment", Object $ HashMap.fromList [circumference, size])
$ pure $ Schema.object [circumference, size]
actual <- graphql (toSchema resolvers) sourceQuery actual <- graphql (toSchema "garment" resolvers) sourceQuery
let expected = object let expected = object
[ "data" .= object [ "data" .= object
[ "garment" .= object [ "garment" .= object
@ -128,7 +136,7 @@ spec = do
} }
}|] }|]
actual <- graphql (toSchema size) sourceQuery actual <- graphql (toSchema "size" size) sourceQuery
actual `shouldNotSatisfy` hasErrors actual `shouldNotSatisfy` hasErrors
describe "Fragment spread executor" $ do describe "Fragment spread executor" $ do
@ -143,7 +151,7 @@ spec = do
} }
|] |]
actual <- graphql (toSchema circumference) sourceQuery actual <- graphql (toSchema "circumference" circumference) sourceQuery
let expected = object let expected = object
[ "data" .= object [ "data" .= object
[ "circumference" .= (60 :: Int) [ "circumference" .= (60 :: Int)
@ -168,7 +176,7 @@ spec = do
} }
|] |]
actual <- graphql (toSchema $ garment "Hat") sourceQuery actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
let expected = object let expected = object
[ "data" .= object [ "data" .= object
[ "garment" .= object [ "garment" .= object
@ -192,7 +200,7 @@ spec = do
} }
|] |]
actual <- graphql (toSchema circumference) sourceQuery actual <- graphql (toSchema "circumference" circumference) sourceQuery
actual `shouldBe` expected actual `shouldBe` expected
it "considers type condition" $ do it "considers type condition" $ do
@ -217,5 +225,5 @@ spec = do
] ]
] ]
] ]
actual <- graphql (toSchema $ garment "Hat") sourceQuery actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
actual `shouldBe` expected actual `shouldBe` expected

15
tests/Test/RootOperationSpec.hs
View File

@ -7,7 +7,6 @@ module Test.RootOperationSpec
import Data.Aeson ((.=), object) import Data.Aeson ((.=), object)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe)
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
@ -16,23 +15,21 @@ import Language.GraphQL.Type.Schema
hatType :: Out.ObjectType IO hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing [] hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.singleton resolverName $ HashMap.singleton "circumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty resolve $ Out.Field Nothing (Out.NamedScalarType int) mempty
where $ pure $ Int 60
(Schema.Resolver resolverName resolve) =
Schema.Resolver "circumference" $ pure $ Out.Int 60
schema :: Schema IO schema :: Schema IO
schema = Schema schema = Schema
(Out.ObjectType "Query" Nothing [] hatField) (Out.ObjectType "Query" Nothing [] hatField)
(Just $ Out.ObjectType "Mutation" Nothing [] incrementField) (Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
where where
garment = pure $ Schema.object garment = pure $ Object $ HashMap.fromList
[ Schema.Resolver "circumference" $ pure $ Out.Int 60 [ ("circumference", Int 60)
] ]
incrementField = HashMap.singleton "incrementCircumference" incrementField = HashMap.singleton "incrementCircumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty $ Out.Field Nothing (Out.NamedScalarType int) mempty
$ pure $ Out.Int 61 $ pure $ Int 61
hatField = HashMap.singleton "garment" hatField = HashMap.singleton "garment"
$ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment $ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment

4
tests/Test/StarWars/Data.hs
View File

@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x
secretBackstory :: Character -> ActionT Identity Text secretBackstory :: ActionT Identity Text
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret." secretBackstory = ActionT $ throwE "secretBackstory is secret."
typeName :: Character -> Text typeName :: Character -> Text
typeName = either (const "Droid") (const "Human") typeName = either (const "Droid") (const "Human")

86
tests/Test/StarWars/Schema.hs
View File

@ -1,24 +1,22 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.StarWars.Schema module Test.StarWars.Schema
( character ( schema
, droid
, hero
, human
, schema
) where ) where
import Control.Monad.Trans.Reader (asks)
import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Functor.Identity (Identity) import Data.Functor.Identity (Identity)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import qualified Language.GraphQL.Schema as Schema import Data.Text (Text)
import Language.GraphQL.Trans import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
import Test.StarWars.Data import Test.StarWars.Data
import Prelude hiding (id)
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
@ -26,50 +24,72 @@ schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing } schema = Schema { query = queryType, mutation = Nothing }
where where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", Out.Field Nothing (Out.NamedScalarType string) mempty hero) [ ("hero", Out.Field Nothing (Out.NamedObjectType heroObject) mempty hero)
, ("human", Out.Field Nothing (Out.NamedScalarType string) mempty human) , ("human", Out.Field Nothing (Out.NamedObjectType heroObject) mempty human)
, ("droid", Out.Field Nothing (Out.NamedScalarType string) mempty droid) , ("droid", Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid)
] ]
hero :: ActionT Identity (Out.Value Identity) heroObject :: Out.ObjectType Identity
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
[ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id"))
, ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name"))
, ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType heroObject) mempty (idField "friends"))
, ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn"))
, ("homePlanet", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "homePlanet"))
, ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory))
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename"))
]
droidObject :: Out.ObjectType Identity
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
[ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id"))
, ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name"))
, ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty (idField "friends"))
, ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn"))
, ("primaryFunction", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "primaryFunction"))
, ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory))
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename"))
]
idField :: Text -> ActionT Identity Value
idField f = do
v <- ActionT $ lift $ asks values
let (Object v') = v
pure $ v' HashMap.! f
hero :: ActionT Identity Value
hero = do hero = do
episode <- argument "episode" episode <- argument "episode"
pure $ character $ case episode of pure $ character $ case episode of
In.Enum "NEWHOPE" -> getHero 4 Enum "NEWHOPE" -> getHero 4
In.Enum "EMPIRE" -> getHero 5 Enum "EMPIRE" -> getHero 5
In.Enum "JEDI" -> getHero 6 Enum "JEDI" -> getHero 6
_ -> artoo _ -> artoo
human :: ActionT Identity (Out.Value Identity) human :: ActionT Identity Value
human = do human = do
id' <- argument "id" id' <- argument "id"
case id' of case id' of
In.String i -> do String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of case humanCharacter of
Nothing -> pure Out.Null Nothing -> pure Null
Just e -> pure $ character e Just e -> pure $ character e
_ -> ActionT $ throwE "Invalid arguments." _ -> ActionT $ throwE "Invalid arguments."
droid :: ActionT Identity (Out.Value Identity) droid :: ActionT Identity Value
droid = do droid = do
id' <- argument "id" id' <- argument "id"
case id' of case id' of
In.String i -> character <$> getDroid i String i -> character <$> getDroid i
_ -> ActionT $ throwE "Invalid arguments." _ -> ActionT $ throwE "Invalid arguments."
character :: Character -> Out.Value Identity character :: Character -> Value
character char = Schema.object character char = Object $ HashMap.fromList
[ Schema.Resolver "id" $ pure $ Out.String $ id_ char [ ("id", String $ id_ char)
, Schema.Resolver "name" $ pure $ Out.String $ name_ char , ("name", String $ name_ char)
, Schema.Resolver "friends" , ("friends", List $ character <$> getFriends char)
$ pure $ Out.List $ character <$> getFriends char , ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
, Schema.Resolver "appearsIn" $ pure , ("homePlanet", String $ either mempty homePlanet char)
$ Out.List $ Out.Enum <$> catMaybes (getEpisode <$> appearsIn char) , ("__typename", String $ typeName char)
, Schema.Resolver "secretBackstory" $ Out.String
<$> secretBackstory char
, Schema.Resolver "homePlanet" $ pure $ Out.String
$ either mempty homePlanet char
, Schema.Resolver "__typename" $ pure $ Out.String
$ typeName char
] ]