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

Check point

Browse Source
This commit is contained in:
Eugen Wissner 2020-05-24 13:51:00 +02:00
parent 7cd4821718
commit eb90a4091c
18 changed files with 281 additions and 271 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
CHANGELOG.md
View File

@ -10,27 +10,32 @@ and this project adheres to
### Fixed ### Fixed
- The parser rejects variables when parsing defaultValue (DefaultValue). The - The parser rejects variables when parsing defaultValue (DefaultValue). The
specification defines default values as `Value` with `const` parameter and specification defines default values as `Value` with `const` parameter and
constant cannot be variables. `AST.Document.ConstValue` was added, constants cannot be variables. `AST.Document.ConstValue` was added,
`AST.Document.ObjectField` was modified. `AST.Document.ObjectField` was modified.
- AST transformation should never fail. - AST transformation should never fail.
* Missing variable are assumed to be null. * Missing variable are assumed to be null.
* Invalid (recusrive or non-existing) fragments should be skipped. * Invalid (recusrive or non-existing) fragments should be skipped.
### Changed ### Changed
- `Resolver` is now `Resolver Name FieldResolver` where `FieldResolver` can - `Schema.Resolver` cannot return arbitrary JSON anymore, but only
contain a JSON value or another resolver, which is invoked during the `Type.Out.Value`.
execution. `FieldResolver` is executed in `ActionT` and the current `Field` is - `Schema.object` takes an array of field resolvers (name, value pairs) and
passed in the reader and not as an explicit argument. returns a resolver (just the function). There is no need in special functions
to construct field resolvers anymore, they can be constructed with just
`Resolver "fieldName" $ pure $ object [...]`.
- `Execute.Transform.operation` has the prior responsibility of - `Execute.Transform.operation` has the prior responsibility of
`Execute.Transform.document`, but transforms only the chosen operation and not `Execute.Transform.document`, but transforms only the chosen operation and not
the whole document. `Execute.Transform.document` translates the whole document. `Execute.Transform.document` translates
`AST.Document.Document` into `Execute.Transform.Document`. `AST.Document.Document` 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.
### Added ### Added
- `Type.Definition` contains input and the most output types. - `Type.Definition` contains input and the most output types.
- `Type.Schema` describes a schema. Both public functions that execute queries - `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 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. operation doesn't match the root Query type in the schema.
- `Type.In` and `Type.Out`.
- `Execute.Coerce` defines a typeclass responsible for input, variable value - `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 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 query variables. Execution functions accept (`HashMap Name a`) instead of
@ -45,6 +50,8 @@ and this project adheres to
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 Integersa and we need
a way to represent objects as a "Field Name -> Resolver" map. a way to represent objects as a "Field Name -> Resolver" map.
- `Schema.wrappedObject`. `Schema.object` creates now wrapped objects.
- `Type` module. Superseded by `Type.Out`.
## [0.7.0.0] - 2020-05-11 ## [0.7.0.0] - 2020-05-11
### Fixed ### Fixed

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

@ -9,15 +9,13 @@ module Language.GraphQL.AST.Core
, Operation(..) , Operation(..)
, Selection(..) , Selection(..)
, TypeCondition , TypeCondition
, Value(..)
) where ) where
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq) import Data.Sequence (Seq)
import Data.String (IsString(..))
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST (Alias, Name, TypeCondition) import Language.GraphQL.AST (Alias, Name, TypeCondition)
import qualified Language.GraphQL.Type.In as In
-- | GraphQL has 3 operation types: queries, mutations and subscribtions. -- | GraphQL has 3 operation types: queries, mutations and subscribtions.
-- --
@ -33,7 +31,7 @@ data Field
deriving (Eq, Show) deriving (Eq, Show)
-- | Argument list. -- | Argument list.
newtype Arguments = Arguments (HashMap Name Value) newtype Arguments = Arguments (HashMap Name In.Value)
deriving (Eq, Show) deriving (Eq, Show)
instance Semigroup Arguments where instance Semigroup Arguments where
@ -56,18 +54,3 @@ data Selection
= SelectionFragment Fragment = SelectionFragment Fragment
| SelectionField Field | SelectionField Field
deriving (Eq, Show) 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

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

@ -15,7 +15,8 @@ import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import Data.Scientific (toBoundedInteger, toRealFloat) import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Document (Name)
import qualified Language.GraphQL.Type.In as In
import Language.GraphQL.Schema import Language.GraphQL.Schema
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
@ -46,26 +47,26 @@ class VariableValue a where
coerceVariableValue coerceVariableValue
:: InputType -- ^ Expected type (variable type given in the query). :: InputType -- ^ Expected type (variable type given in the query).
-> a -- ^ Variable value being coerced. -> a -- ^ Variable value being coerced.
-> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise. -> Maybe In.Value -- ^ Coerced value on success, 'Nothing' otherwise.
instance VariableValue Aeson.Value where instance VariableValue Aeson.Value where
coerceVariableValue _ Aeson.Null = Just Null coerceVariableValue _ Aeson.Null = Just In.Null
coerceVariableValue (ScalarInputTypeDefinition scalarType) value coerceVariableValue (ScalarInputTypeDefinition scalarType) value
| (Aeson.String stringValue) <- value = Just $ String stringValue | (Aeson.String stringValue) <- value = Just $ In.String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue | (Aeson.Bool booleanValue) <- value = Just $ In.Boolean booleanValue
| (Aeson.Number numberValue) <- value | (Aeson.Number numberValue) <- value
, (ScalarType "Float" _) <- scalarType = , (ScalarType "Float" _) <- scalarType =
Just $ Float $ toRealFloat numberValue Just $ In.Float $ toRealFloat numberValue
| (Aeson.Number numberValue) <- value = -- ID or Int | (Aeson.Number numberValue) <- value = -- ID or Int
Int <$> toBoundedInteger numberValue In.Int <$> toBoundedInteger numberValue
coerceVariableValue (EnumInputTypeDefinition _) (Aeson.String stringValue) = coerceVariableValue (EnumInputTypeDefinition _) (Aeson.String stringValue) =
Just $ Enum stringValue Just $ In.Enum stringValue
coerceVariableValue (ObjectInputTypeDefinition objectType) value coerceVariableValue (ObjectInputTypeDefinition objectType) value
| (Aeson.Object objectValue) <- value = do | (Aeson.Object objectValue) <- value = do
let (InputObjectType _ _ inputFields) = objectType let (InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue if HashMap.null newObjectValue
then Just $ Object resultMap then Just $ In.Object resultMap
else Nothing else Nothing
where where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
@ -81,7 +82,7 @@ instance VariableValue Aeson.Value where
pure (newObjectValue, insert coerced) pure (newObjectValue, insert coerced)
Nothing -> Just (objectValue, resultMap) Nothing -> Just (objectValue, resultMap)
coerceVariableValue (ListInputTypeDefinition listType) value coerceVariableValue (ListInputTypeDefinition listType) value
| (Aeson.Array arrayValue) <- value = List | (Aeson.Array arrayValue) <- value = In.List
<$> foldr foldVector (Just []) arrayValue <$> foldr foldVector (Just []) arrayValue
| otherwise = coerceVariableValue listType value | otherwise = coerceVariableValue listType value
where where
@ -95,7 +96,7 @@ instance VariableValue Aeson.Value where
-- corresponding types. -- corresponding types.
coerceInputLiterals coerceInputLiterals
:: HashMap Name InputType :: HashMap Name InputType
-> HashMap Name Value -> HashMap Name In.Value
-> Maybe Subs -> Maybe Subs
coerceInputLiterals variableTypes variableValues = coerceInputLiterals variableTypes variableValues =
foldWithKey operator variableTypes foldWithKey operator variableTypes
@ -105,34 +106,34 @@ coerceInputLiterals variableTypes variableValues =
<$> (lookupVariable variableName >>= coerceInputLiteral variableType) <$> (lookupVariable variableName >>= coerceInputLiteral variableType)
<*> resultMap <*> resultMap
coerceInputLiteral (ScalarInputType type') value coerceInputLiteral (ScalarInputType type') value
| (String stringValue) <- value | (In.String stringValue) <- value
, (ScalarType "String" _) <- type' = Just $ String stringValue , (ScalarType "String" _) <- type' = Just $ In.String stringValue
| (Boolean booleanValue) <- value | (In.Boolean booleanValue) <- value
, (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue , (ScalarType "Boolean" _) <- type' = Just $ In.Boolean booleanValue
| (Int intValue) <- value | (In.Int intValue) <- value
, (ScalarType "Int" _) <- type' = Just $ Int intValue , (ScalarType "Int" _) <- type' = Just $ In.Int intValue
| (Float floatValue) <- value | (In.Float floatValue) <- value
, (ScalarType "Float" _) <- type' = Just $ Float floatValue , (ScalarType "Float" _) <- type' = Just $ In.Float floatValue
| (Int intValue) <- value | (In.Int intValue) <- value
, (ScalarType "Float" _) <- type' = , (ScalarType "Float" _) <- type' =
Just $ Float $ fromIntegral intValue Just $ In.Float $ fromIntegral intValue
| (String stringValue) <- value | (In.String stringValue) <- value
, (ScalarType "ID" _) <- type' = Just $ String stringValue , (ScalarType "ID" _) <- type' = Just $ In.String stringValue
| (Int intValue) <- value | (In.Int intValue) <- value
, (ScalarType "ID" _) <- type' = Just $ decimal intValue , (ScalarType "ID" _) <- type' = Just $ decimal intValue
coerceInputLiteral (EnumInputType type') (Enum enumValue) coerceInputLiteral (EnumInputType type') (In.Enum enumValue)
| member enumValue type' = Just $ Enum enumValue | member enumValue type' = Just $ In.Enum enumValue
coerceInputLiteral (ObjectInputType type') (Object _) = coerceInputLiteral (ObjectInputType type') (In.Object _) =
let (InputObjectType _ _ inputFields) = type' let (InputObjectType _ _ inputFields) = type'
in Object <$> foldWithKey matchFieldValues inputFields in 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 (InputField _ type' defaultValue) resultMap = matchFieldValues fieldName (InputField _ type' defaultValue) resultMap =
case lookupVariable fieldName of case lookupVariable fieldName of
Just Null Just In.Null
| isNonNullInputType type' -> Nothing | isNonNullInputType type' -> Nothing
| otherwise -> | otherwise ->
HashMap.insert fieldName Null <$> resultMap HashMap.insert fieldName In.Null <$> resultMap
Just variableValue -> HashMap.insert fieldName Just variableValue -> HashMap.insert fieldName
<$> coerceInputLiteral type' variableValue <$> coerceInputLiteral type' variableValue
<*> resultMap <*> resultMap
@ -144,7 +145,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 = String decimal = In.String
. Text.Lazy.toStrict . Text.Lazy.toStrict
. Text.Builder.toLazyText . Text.Builder.toLazyText
. Text.Builder.decimal . Text.Builder.decimal

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

@ -32,6 +32,7 @@ import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Directive as Directive import qualified Language.GraphQL.Type.Directive as Directive
import qualified Language.GraphQL.Type.In as In
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.
@ -136,23 +137,23 @@ coerceVariableValues schema operationDefinition variableValues' =
<*> coercedValues <*> coercedValues
choose Nothing defaultValue variableType choose Nothing defaultValue variableType
| Just _ <- defaultValue = defaultValue | Just _ <- defaultValue = defaultValue
| not (isNonNullInputType variableType) = Just Core.Null | not (isNonNullInputType variableType) = Just In.Null
choose (Just value') _ variableType choose (Just value') _ variableType
| Just coercedValue <- coerceVariableValue variableType value' | Just coercedValue <- coerceVariableValue variableType value'
, not (isNonNullInputType variableType) || coercedValue /= Core.Null = , not (isNonNullInputType variableType) || coercedValue /= In.Null =
Just coercedValue Just coercedValue
choose _ _ _ = Nothing choose _ _ _ = Nothing
constValue :: Full.ConstValue -> Core.Value constValue :: Full.ConstValue -> In.Value
constValue (Full.ConstInt i) = Core.Int i constValue (Full.ConstInt i) = In.Int i
constValue (Full.ConstFloat f) = Core.Float f constValue (Full.ConstFloat f) = In.Float f
constValue (Full.ConstString x) = Core.String x constValue (Full.ConstString x) = In.String x
constValue (Full.ConstBoolean b) = Core.Boolean b constValue (Full.ConstBoolean b) = In.Boolean b
constValue Full.ConstNull = Core.Null constValue Full.ConstNull = In.Null
constValue (Full.ConstEnum e) = Core.Enum e constValue (Full.ConstEnum e) = In.Enum e
constValue (Full.ConstList l) = Core.List $ constValue <$> l constValue (Full.ConstList l) = In.List $ constValue <$> l
constValue (Full.ConstObject o) = constValue (Full.ConstObject o) =
Core.Object $ HashMap.fromList $ constObjectField <$> o In.Object $ HashMap.fromList $ constObjectField <$> o
where where
constObjectField (Full.ObjectField key value') = (key, constValue value') constObjectField (Full.ObjectField key value') = (key, constValue value')
@ -294,19 +295,19 @@ arguments = fmap Core.Arguments . foldM go HashMap.empty
substitutedValue <- value value' substitutedValue <- value value'
return $ HashMap.insert name substitutedValue arguments' return $ HashMap.insert name substitutedValue arguments'
value :: Full.Value -> TransformT Core.Value value :: Full.Value -> TransformT In.Value
value (Full.Variable name) = value (Full.Variable name) =
gets $ fromMaybe Core.Null . HashMap.lookup name . variableValues gets $ fromMaybe In.Null . HashMap.lookup name . variableValues
value (Full.Int i) = pure $ Core.Int i value (Full.Int i) = pure $ In.Int i
value (Full.Float f) = pure $ Core.Float f value (Full.Float f) = pure $ In.Float f
value (Full.String x) = pure $ Core.String x value (Full.String x) = pure $ In.String x
value (Full.Boolean b) = pure $ Core.Boolean b value (Full.Boolean b) = pure $ In.Boolean b
value Full.Null = pure Core.Null value Full.Null = pure In.Null
value (Full.Enum e) = pure $ Core.Enum e value (Full.Enum e) = pure $ In.Enum e
value (Full.List l) = value (Full.List l) =
Core.List <$> traverse value l In.List <$> traverse value l
value (Full.Object o) = value (Full.Object o) =
Core.Object . HashMap.fromList <$> traverse objectField o In.Object . HashMap.fromList <$> traverse objectField o
objectField :: Full.ObjectField Full.Value -> TransformT (Core.Name, Core.Value) objectField :: Full.ObjectField Full.Value -> TransformT (Core.Name, In.Value)
objectField (Full.ObjectField name value') = (name,) <$> value value' objectField (Full.ObjectField name value') = (name,) <$> value value'

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

@ -1,3 +1,4 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to -- | This module provides a representation of a @GraphQL@ Schema in addition to
@ -8,10 +9,6 @@ module Language.GraphQL.Schema
, object , object
, resolve , resolve
, resolversToMap , resolversToMap
, wrappedObject
-- * AST Reexports
, Field
, Value(..)
) where ) where
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
@ -28,38 +25,35 @@ import qualified Data.Text as T
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Core
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Trans import Language.GraphQL.Trans
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type as Type 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
-- information (if an error has occurred). @m@ is an arbitrary monad, usually -- information (if an error has occurred). @m@ is an arbitrary monad, usually
-- 'IO'. -- 'IO'.
data Resolver m = Resolver Name (Definition.FieldResolver m) --
-- 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 Name (ActionT m (Out.Value m))
-- | Converts resolvers to a map. -- | Converts resolvers to a map.
resolversToMap :: (Foldable f, Functor f) resolversToMap :: (Foldable f, Functor f)
=> f (Resolver m) => forall m
-> HashMap Text (Definition.FieldResolver m) . f (Resolver m)
-> HashMap Text (ActionT m (Out.Value m))
resolversToMap = HashMap.fromList . toList . fmap toKV resolversToMap = HashMap.fromList . toList . fmap toKV
where where
toKV (Resolver name r) = (name, r) toKV (Resolver name r) = (name, r)
-- | Contains variables for the query. The key of the map is a variable name, -- | Contains variables for the query. The key of the map is a variable name,
-- and the value is the variable value. -- and the value is the variable value.
type Subs = HashMap Name Value type Subs = HashMap Name In.Value
-- | Like 'object' but can be null or a list of objects. -- | Create a new 'Resolver' with the given 'Name' from the given
wrappedObject :: Monad m -- Resolver's.
=> Name object :: Monad m => [Resolver m] -> Out.Value m
-> ActionT m (Type.Wrapping (Definition.FieldResolver m)) object = Out.Object . resolversToMap
-> Resolver m
wrappedObject name = Resolver name . Definition.NestingResolver
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: Monad m
=> [Resolver m]
-> Type.Wrapping (Definition.FieldResolver m)
object = Type.O . resolversToMap
resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a) resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
resolveFieldValue field@(Field _ _ args _) = resolveFieldValue field@(Field _ _ args _) =
@ -69,26 +63,25 @@ resolveFieldValue field@(Field _ _ args _) =
withField :: Monad m withField :: Monad m
=> Field => Field
-> Definition.FieldResolver m -> ActionT m (Out.Value m)
-> CollectErrsT m Aeson.Object -> CollectErrsT m Aeson.Object
withField field (Definition.ValueResolver resolver) = do withField field resolver = do
answer <- lift $ resolveFieldValue field resolver
either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
withField field (Definition.NestingResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver answer <- lift $ resolveFieldValue field resolver
case answer of case answer of
Right result -> HashMap.singleton (aliasOrName field) <$> toJSON field result Right result -> HashMap.singleton (aliasOrName field)
<$> toJSON field result
Left errorMessage -> errmsg field errorMessage Left errorMessage -> errmsg field errorMessage
toJSON :: Monad m => Field -> Type.Wrapping (Definition.FieldResolver m) -> CollectErrsT m Aeson.Value toJSON :: Monad m => Field -> Out.Value m -> CollectErrsT m Aeson.Value
toJSON _ Type.Null = pure Aeson.Null toJSON _ Out.Null = pure Aeson.Null
toJSON _ (Type.I i) = pure $ Aeson.toJSON i toJSON _ (Out.Int integer) = pure $ Aeson.toJSON integer
toJSON _ (Type.B i) = pure $ Aeson.toJSON i toJSON _ (Out.Boolean boolean) = pure $ Aeson.Bool boolean
toJSON _ (Type.F i) = pure $ Aeson.toJSON i toJSON _ (Out.Float float) = pure $ Aeson.toJSON float
toJSON _ (Type.E i) = pure $ Aeson.toJSON i toJSON _ (Out.Enum enum) = pure $ Aeson.String enum
toJSON _ (Type.S i) = pure $ Aeson.toJSON i toJSON _ (Out.String string) = pure $ Aeson.String string
toJSON field (Type.List list) = Aeson.toJSON <$> traverse (toJSON field) list toJSON field (Out.List list) = Aeson.toJSON <$> traverse (toJSON field) list
toJSON (Field _ _ _ seqSelection) (Type.O map') = map' `resolve` seqSelection toJSON (Field _ _ _ seqSelection) (Out.Object map') =
map' `resolve` seqSelection
errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value) errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value)
errmsg field errorMessage = do errmsg field errorMessage = do
@ -99,7 +92,7 @@ errmsg field errorMessage = do
-- '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
=> HashMap Text (Definition.FieldResolver m) => HashMap Text (ActionT m (Out.Value m))
-> Seq Selection -> Seq Selection
-> CollectErrsT m Aeson.Value -> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
@ -109,17 +102,11 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
| (Just resolver) <- lookupResolver name = withField fld resolver | (Just resolver) <- lookupResolver name = withField fld resolver
| otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."] | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
tryResolvers (SelectionFragment (Fragment typeCondition selections')) tryResolvers (SelectionFragment (Fragment typeCondition selections'))
| Just (Definition.ValueResolver resolver) <- lookupResolver "__typename" = do | Just resolver <- lookupResolver "__typename" = do
let fakeField = Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue fakeField resolver
if Right (Aeson.String typeCondition) == that
then fmap fold . traverse tryResolvers $ selections'
else pure mempty
| Just (Definition.NestingResolver resolver) <- lookupResolver "__typename" = do
let fakeField = Field Nothing "__typename" mempty mempty let fakeField = Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue fakeField resolver that <- lift $ resolveFieldValue fakeField resolver
case that of case that of
Right (Type.S typeCondition') Right (Out.String typeCondition')
| typeCondition' == typeCondition -> | typeCondition' == typeCondition ->
fmap fold . traverse tryResolvers $ selections' fmap fold . traverse tryResolvers $ selections'
_ -> pure mempty _ -> pure mempty

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

@ -15,6 +15,7 @@ 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 Prelude hiding (lookup) import Prelude hiding (lookup)
-- | Resolution context holds resolver arguments. -- | Resolution context holds resolver arguments.
@ -55,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 'Value.Null' (i.e. the argument is assumed to -- be found, returns 'In.Null' (i.e. the argument is assumed to
-- be optional then). -- be optional then).
argument :: Monad m => Name -> ActionT m Value argument :: Monad m => Name -> ActionT m In.Value
argument argumentName = do argument argumentName = do
argumentValue <- ActionT $ lift $ asks $ lookup . arguments argumentValue <- ActionT $ lift $ asks $ lookup . arguments
pure $ fromMaybe Null argumentValue pure $ fromMaybe In.Null argumentValue
where where
lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap

63
src/Language/GraphQL/Type.hs
View File

@ -1,63 +0,0 @@
-- | Definitions for @GraphQL@ input types.
module Language.GraphQL.Type
( Wrapping(..)
) where
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Language.GraphQL.AST.Document (Name)
-- | 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
| O (HashMap Name a)
| I Int
| B Bool
| F Float
| E Text
| S Text
deriving (Eq, Show)
instance Functor Wrapping where
fmap f (List list) = List $ fmap (fmap f) list
fmap f (O map') = O $ f <$> map'
fmap _ Null = Null
fmap _ (I i) = I i
fmap _ (B i) = B i
fmap _ (F i) = F i
fmap _ (E i) = E i
fmap _ (S i) = S i
{-instance Foldable Wrapping where
foldr f acc (List list) = foldr (flip $ foldr f) acc list
foldr f acc (O map') = foldr f acc map'
foldr _ acc _ = 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
traverse f (O map') = O <$> traverse f map'-}
{-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-}

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

@ -8,7 +8,6 @@ module Language.GraphQL.Type.Definition
( Argument(..) ( Argument(..)
, EnumType(..) , EnumType(..)
, Field(..) , Field(..)
, FieldResolver(..)
, InputField(..) , InputField(..)
, InputObjectType(..) , InputObjectType(..)
, InputType(..) , InputType(..)
@ -31,13 +30,13 @@ module Language.GraphQL.Type.Definition
, string , string
) where ) where
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Core (Name, Value) import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Trans 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 Prelude hiding (id) import Prelude hiding (id)
-- | Object type definition. -- | Object type definition.
@ -51,17 +50,10 @@ data Field m = Field
(Maybe Text) -- ^ Description. (Maybe Text) -- ^ Description.
(OutputType m) -- ^ Field type. (OutputType m) -- ^ Field type.
(HashMap Name Argument) -- ^ Arguments. (HashMap Name Argument) -- ^ Arguments.
(FieldResolver m) -- ^ Resolver. (ActionT m (Out.Value m)) -- ^ Resolver.
-- | 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 FieldResolver m
= ValueResolver (ActionT m Aeson.Value)
| NestingResolver (ActionT m (Type.Wrapping (FieldResolver m)))
-- | Field argument definition. -- | Field argument definition.
data Argument = Argument (Maybe Text) InputType (Maybe Value) data Argument = Argument (Maybe Text) InputType (Maybe In.Value)
-- | Scalar type definition. -- | Scalar type definition.
-- --
@ -77,7 +69,7 @@ data ScalarType = ScalarType Name (Maybe Text)
data EnumType = EnumType Name (Maybe Text) (Set Text) data EnumType = EnumType Name (Maybe Text) (Set Text)
-- | Single field of an 'InputObjectType'. -- | Single field of an 'InputObjectType'.
data InputField = InputField (Maybe Text) InputType (Maybe Value) data InputField = InputField (Maybe Text) InputType (Maybe In.Value)
-- | Input object type definition. -- | Input object type definition.
-- --

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

@ -6,6 +6,7 @@ module Language.GraphQL.Type.Directive
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
-- | Directive processing status. -- | Directive processing status.
data Status data Status
@ -36,7 +37,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 (Boolean True)) -> Skip (Just (In.Boolean True)) -> Skip
_ -> Include directive' _ -> Include directive'
skip' directive' = Continue directive' skip' directive' = Continue directive'
@ -45,6 +46,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 (Boolean True)) -> Include directive' (Just (In.Boolean True)) -> Include directive'
_ -> Skip _ -> Skip
include' directive' = Continue directive' include' directive' = Continue directive'

26
src/Language/GraphQL/Type/In.hs Normal file
View File

@ -0,0 +1,26 @@
-- | This module is intended to be imported qualified, to avoid name clashes
-- with 'Language.GraphQL.Type.Out'.
module Language.GraphQL.Type.In
( Value(..)
) where
import Data.HashMap.Strict (HashMap)
import Data.Int (Int32)
import Data.String (IsString(..))
import Data.Text (Text)
import Language.GraphQL.AST.Document (Name)
-- | 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

58
src/Language/GraphQL/Type/Out.hs Normal file
View File

@ -0,0 +1,58 @@
{-# LANGUAGE OverloadedStrings #-}
-- | This module is intended to be imported qualified, to avoid name clashes
-- with 'Language.GraphQL.Type.In'.
module Language.GraphQL.Type.Out
( Value(..)
) where
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 qualified Data.Text as Text
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Trans
-- | 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

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

@ -15,6 +15,7 @@ import Language.GraphQL.AST.Core
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Schema import Language.GraphQL.Schema
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
import Prelude hiding (id) import Prelude hiding (id)
import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
@ -22,12 +23,12 @@ direction :: EnumType
direction = EnumType "Direction" Nothing direction = EnumType "Direction" Nothing
$ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"] $ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"]
coerceInputLiteral :: InputType -> Value -> Maybe Subs coerceInputLiteral :: InputType -> In.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 Value) -> Maybe Value lookupActual :: Maybe (HashMap Name In.Value) -> Maybe In.Value
lookupActual = (HashMap.lookup "variableName" =<<) lookupActual = (HashMap.lookup "variableName" =<<)
singletonInputObject :: InputType singletonInputObject :: InputType
@ -41,22 +42,22 @@ spec :: Spec
spec = do spec = do
describe "ToGraphQL Aeson" $ do describe "ToGraphQL Aeson" $ do
it "coerces strings" $ it "coerces strings" $
let expected = Just (String "asdf") let expected = Just (In.String "asdf")
actual = coerceVariableValue actual = coerceVariableValue
(ScalarInputType string) (Aeson.String "asdf") (ScalarInputType 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 (String "asdf") let expected = Just (In.String "asdf")
actual = coerceVariableValue actual = coerceVariableValue
(NonNullScalarInputType string) (Aeson.String "asdf") (NonNullScalarInputType string) (Aeson.String "asdf")
in actual `shouldBe` expected in actual `shouldBe` expected
it "coerces booleans" $ it "coerces booleans" $
let expected = Just (Boolean True) let expected = Just (In.Boolean True)
actual = coerceVariableValue actual = coerceVariableValue
(ScalarInputType boolean) (Aeson.Bool True) (ScalarInputType 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 (Int 0) let expected = Just (In.Int 0)
actual = coerceVariableValue actual = coerceVariableValue
(ScalarInputType int) (Aeson.Number 0) (ScalarInputType int) (Aeson.Number 0)
in actual `shouldBe` expected in actual `shouldBe` expected
@ -65,24 +66,24 @@ spec = do
(ScalarInputType int) (Aeson.Number $ scientific 14 (-1)) (ScalarInputType 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 (Float 1.4) let expected = Just (In.Float 1.4)
actual = coerceVariableValue actual = coerceVariableValue
(ScalarInputType float) (Aeson.Number $ scientific 14 (-1)) (ScalarInputType float) (Aeson.Number $ scientific 14 (-1))
in actual `shouldBe` expected in actual `shouldBe` expected
it "coerces IDs" $ it "coerces IDs" $
let expected = Just (String "1234") let expected = Just (In.String "1234")
actual = coerceVariableValue actual = coerceVariableValue
(ScalarInputType id) (Aeson.String "1234") (ScalarInputType 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 $ Object $ HashMap.singleton "field" "asdf" expected = Just $ In.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 $ Object HashMap.empty expected = Just $ In.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
@ -94,25 +95,25 @@ spec = do
in actual `shouldSatisfy` isNothing in actual `shouldSatisfy` isNothing
it "preserves null" $ it "preserves null" $
let actual = coerceVariableValue (ScalarInputType id) Aeson.Null let actual = coerceVariableValue (ScalarInputType id) Aeson.Null
in actual `shouldBe` Just Null in actual `shouldBe` Just In.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 = (ListInputType $ ScalarInputType string) listType = (ListInputType $ ScalarInputType string)
actual = coerceVariableValue listType list actual = coerceVariableValue listType list
expected = Just $ List [String "asdf", String "qwer"] expected = Just $ In.List [In.String "asdf", In.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 (Enum "NORTH") let expected = Just (In.Enum "NORTH")
actual = coerceInputLiteral actual = coerceInputLiteral
(EnumInputType direction) (Enum "NORTH") (EnumInputType direction) (In.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
(EnumInputType direction) (Enum "NORTH_EAST") (EnumInputType direction) (In.Enum "NORTH_EAST")
in actual `shouldSatisfy` isNothing in actual `shouldSatisfy` isNothing
it "coerces integers to IDs" $ it "coerces integers to IDs" $
let expected = Just (String "1234") let expected = Just (In.String "1234")
actual = coerceInputLiteral (ScalarInputType id) (Int 1234) actual = coerceInputLiteral (ScalarInputType id) (In.Int 1234)
in lookupActual actual `shouldBe` expected in lookupActual actual `shouldBe` expected

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

@ -10,16 +10,15 @@ import qualified Data.Sequence as Sequence
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Core
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Schema import Language.GraphQL.Schema
import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Definition
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe)
spec :: Spec spec :: Spec
spec = spec =
describe "resolve" $ describe "resolve" $
it "ignores invalid __typename" $ do it "ignores invalid __typename" $ do
let resolver = NestingResolver $ pure $ object let resolver = pure $ object
[ wrappedObject "field" $ pure $ Type.S "T" [ Resolver "field" $ pure $ Out.String "T"
] ]
schema = HashMap.singleton "__typename" resolver schema = HashMap.singleton "__typename" resolver
fields = Sequence.singleton fields = Sequence.singleton

15
tests/Language/GraphQL/Type/OutSpec.hs Normal file
View File

@ -0,0 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Type.OutSpec
( spec
) where
import Data.Functor.Identity (Identity)
import qualified Language.GraphQL.Type.Out as Out
import Test.Hspec (Spec, describe, it, shouldBe)
spec :: Spec
spec =
describe "Value" $
it "supports overloaded strings" $
let string = "Goldstaub abblasen." :: (Out.Value Identity)
in string `shouldBe` Out.String "Goldstaub abblasen."

3
tests/Test/DirectiveSpec.hs
View File

@ -8,6 +8,7 @@ import Data.Aeson (Value(..), object, (.=))
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
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema(..)) import Language.GraphQL.Type.Schema (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)
@ -15,7 +16,7 @@ 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 = ValueResolver $ pure $ Number 5 resolver = pure $ Out.Int 5
queryType = ObjectType "Query" Nothing queryType = ObjectType "Query" Nothing
$ HashMap.singleton "experimentalField" $ HashMap.singleton "experimentalField"
$ Field Nothing (ScalarOutputType int) mempty resolver $ Field Nothing (ScalarOutputType int) mempty resolver

16
tests/Test/FragmentSpec.hs
View File

@ -9,7 +9,9 @@ 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 qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type as Type import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
import Test.Hspec import Test.Hspec
( Spec ( Spec
, describe , describe
@ -17,21 +19,19 @@ import Test.Hspec
, shouldBe , shouldBe
, shouldNotSatisfy , shouldNotSatisfy
) )
import Language.GraphQL.Type.Definition
import Language.GraphQL.Type.Schema
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
size :: Schema.Resolver IO size :: Schema.Resolver IO
size = Schema.wrappedObject "size" $ pure $ Type.S "L" size = Schema.Resolver "size" $ pure $ Out.String "L"
circumference :: Schema.Resolver IO circumference :: Schema.Resolver IO
circumference = Schema.wrappedObject "circumference" $ pure $ Type.I 60 circumference = Schema.Resolver "circumference" $ pure $ Out.Int 60
garment :: Text -> Schema.Resolver IO garment :: Text -> Schema.Resolver IO
garment typeName = Schema.wrappedObject "garment" garment typeName = Schema.Resolver "garment"
$ pure $ Schema.object $ pure $ Schema.object
[ if typeName == "Hat" then circumference else size [ if typeName == "Hat" then circumference else size
, Schema.wrappedObject "__typename" $ pure $ Type.S typeName , Schema.Resolver "__typename" $ pure $ Out.String typeName
] ]
inlineQuery :: Text inlineQuery :: Text
@ -107,7 +107,7 @@ spec = do
} }
} }
}|] }|]
resolvers = Schema.wrappedObject "garment" resolvers = Schema.Resolver "garment"
$ pure $ Schema.object [circumference, size] $ pure $ Schema.object [circumference, size]
actual <- graphql (toSchema resolvers) sourceQuery actual <- graphql (toSchema resolvers) sourceQuery

11
tests/Test/RootOperationSpec.hs
View File

@ -11,8 +11,8 @@ 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
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
import qualified Language.GraphQL.Type as Type
hatType :: ObjectType IO hatType :: ObjectType IO
hatType = ObjectType "Hat" Nothing hatType = ObjectType "Hat" Nothing
@ -20,20 +20,19 @@ hatType = ObjectType "Hat" Nothing
$ Field Nothing (ScalarOutputType int) mempty resolve $ Field Nothing (ScalarOutputType int) mempty resolve
where where
(Schema.Resolver resolverName resolve) = (Schema.Resolver resolverName resolve) =
Schema.wrappedObject "circumference" $ pure $ Type.I 60 Schema.Resolver "circumference" $ pure $ Out.Int 60
schema :: Schema IO schema :: Schema IO
schema = Schema schema = Schema
(ObjectType "Query" Nothing hatField) (ObjectType "Query" Nothing hatField)
(Just $ ObjectType "Mutation" Nothing incrementField) (Just $ ObjectType "Mutation" Nothing incrementField)
where where
garment = NestingResolver garment = pure $ Schema.object
$ pure $ Schema.object [ Schema.Resolver "circumference" $ pure $ Out.Int 60
[ Schema.wrappedObject "circumference" $ pure $ Type.I 60
] ]
incrementField = HashMap.singleton "incrementCircumference" incrementField = HashMap.singleton "incrementCircumference"
$ Field Nothing (ScalarOutputType int) mempty $ Field Nothing (ScalarOutputType int) mempty
$ NestingResolver $ pure $ Type.I 61 $ pure $ Out.Int 61
hatField = HashMap.singleton "garment" hatField = HashMap.singleton "garment"
$ Field Nothing (ObjectOutputType hatType) mempty garment $ Field Nothing (ObjectOutputType hatType) mempty garment

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

@ -15,7 +15,8 @@ import Data.Maybe (catMaybes)
import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Trans import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
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 Language.GraphQL.Type.Schema
import Test.StarWars.Data import Test.StarWars.Data
@ -30,45 +31,45 @@ schema = Schema { query = queryType, mutation = Nothing }
, ("droid", Field Nothing (ScalarOutputType string) mempty droid) , ("droid", Field Nothing (ScalarOutputType string) mempty droid)
] ]
hero :: FieldResolver Identity hero :: ActionT Identity (Out.Value Identity)
hero = NestingResolver $ do hero = do
episode <- argument "episode" episode <- argument "episode"
pure $ character $ case episode of pure $ character $ case episode of
Schema.Enum "NEWHOPE" -> getHero 4 In.Enum "NEWHOPE" -> getHero 4
Schema.Enum "EMPIRE" -> getHero 5 In.Enum "EMPIRE" -> getHero 5
Schema.Enum "JEDI" -> getHero 6 In.Enum "JEDI" -> getHero 6
_ -> artoo _ -> artoo
human :: FieldResolver Identity human :: ActionT Identity (Out.Value Identity)
human = NestingResolver $ do human = do
id' <- argument "id" id' <- argument "id"
case id' of case id' of
Schema.String i -> do In.String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of case humanCharacter of
Nothing -> pure Type.Null Nothing -> pure Out.Null
Just e -> pure $ character e Just e -> pure $ character e
_ -> ActionT $ throwE "Invalid arguments." _ -> ActionT $ throwE "Invalid arguments."
droid :: FieldResolver Identity droid :: ActionT Identity (Out.Value Identity)
droid = NestingResolver $ do droid = do
id' <- argument "id" id' <- argument "id"
case id' of case id' of
Schema.String i -> getDroid i >>= pure . character In.String i -> getDroid i >>= pure . character
_ -> ActionT $ throwE "Invalid arguments." _ -> ActionT $ throwE "Invalid arguments."
character :: Character -> Type.Wrapping (FieldResolver Identity) character :: Character -> Out.Value Identity
character char = Schema.object character char = Schema.object
[ Schema.wrappedObject "id" $ pure $ Type.S $ id_ char [ Schema.Resolver "id" $ pure $ Out.String $ id_ char
, Schema.wrappedObject "name" $ pure $ Type.S $ name_ char , Schema.Resolver "name" $ pure $ Out.String $ name_ char
, Schema.wrappedObject "friends" , Schema.Resolver "friends"
$ pure $ pure $ Out.List $ fmap character $ getFriends char
$ Type.List , Schema.Resolver "appearsIn" $ pure
$ fmap character $ Out.List $ Out.Enum <$> catMaybes (getEpisode <$> appearsIn char)
$ getFriends char , Schema.Resolver "secretBackstory" $ Out.String
, Schema.wrappedObject "appearsIn" $ pure <$> secretBackstory char
$ Type.List $ Type.E <$> catMaybes (getEpisode <$> appearsIn char) , Schema.Resolver "homePlanet" $ pure $ Out.String
, Schema.wrappedObject "secretBackstory" $ Type.S <$> secretBackstory char $ either mempty homePlanet char
, Schema.wrappedObject "homePlanet" $ pure $ Type.S $ either mempty homePlanet char , Schema.Resolver "__typename" $ pure $ Out.String
, Schema.wrappedObject "__typename" $ pure $ Type.S $ typeName char $ typeName char
] ]