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
- The parser rejects variables when parsing defaultValue (DefaultValue). The
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 transformation should never fail.
* Missing variable are assumed to be null.
* Invalid (recusrive or non-existing) fragments should be skipped.
### Changed
- `Resolver` is now `Resolver Name FieldResolver` where `FieldResolver` can
contain a JSON value or another resolver, which is invoked during the
execution. `FieldResolver` is executed in `ActionT` and the current `Field` is
passed in the reader and not as an explicit argument.
- `Schema.Resolver` cannot return arbitrary JSON anymore, but only
`Type.Out.Value`.
- `Schema.object` takes an array of field resolvers (name, value pairs) and
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.document`, but transforms only the chosen operation and not
the whole document. `Execute.Transform.document` translates
`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
- `Type.Definition` contains input and the most output types.
- `Type.Schema` describes a schema. Both public functions that execute queries
accept a `Schema` now instead of a `HashMap`. The execution fails if the root
operation doesn't match the root Query type in the schema.
- `Type.In` and `Type.Out`.
- `Execute.Coerce` defines a typeclass responsible for input, variable value
coercion. It decouples us a bit from JSON since any format can be used to pass
query variables. Execution functions accept (`HashMap Name a`) instead of
@ -45,6 +50,8 @@ and this project adheres to
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
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
### Fixed

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

@ -9,15 +9,13 @@ module Language.GraphQL.AST.Core
, Operation(..)
, Selection(..)
, TypeCondition
, Value(..)
) where
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq)
import Data.String (IsString(..))
import Data.Text (Text)
import Language.GraphQL.AST (Alias, Name, TypeCondition)
import qualified Language.GraphQL.Type.In as In
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
--
@ -33,7 +31,7 @@ data Field
deriving (Eq, Show)
-- | Argument list.
newtype Arguments = Arguments (HashMap Name Value)
newtype Arguments = Arguments (HashMap Name In.Value)
deriving (Eq, Show)
instance Semigroup Arguments where
@ -56,18 +54,3 @@ data Selection
= SelectionFragment Fragment
| SelectionField Field
deriving (Eq, Show)
-- | Represents accordingly typed GraphQL values.
data Value
= Int Int32
| Float Double -- ^ GraphQL Float is double precision
| String Text
| Boolean Bool
| Null
| Enum Name
| List [Value]
| Object (HashMap Name Value)
deriving (Eq, Show)
instance IsString Value where
fromString = String . fromString

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.Int as Text.Builder
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.Type.Definition
@ -46,26 +47,26 @@ class VariableValue a where
coerceVariableValue
:: InputType -- ^ Expected type (variable type given in the query).
-> 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
coerceVariableValue _ Aeson.Null = Just Null
coerceVariableValue _ Aeson.Null = Just In.Null
coerceVariableValue (ScalarInputTypeDefinition scalarType) value
| (Aeson.String stringValue) <- value = Just $ String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue
| (Aeson.String stringValue) <- value = Just $ In.String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ In.Boolean booleanValue
| (Aeson.Number numberValue) <- value
, (ScalarType "Float" _) <- scalarType =
Just $ Float $ toRealFloat numberValue
Just $ In.Float $ toRealFloat numberValue
| (Aeson.Number numberValue) <- value = -- ID or Int
Int <$> toBoundedInteger numberValue
In.Int <$> toBoundedInteger numberValue
coerceVariableValue (EnumInputTypeDefinition _) (Aeson.String stringValue) =
Just $ Enum stringValue
Just $ In.Enum stringValue
coerceVariableValue (ObjectInputTypeDefinition objectType) value
| (Aeson.Object objectValue) <- value = do
let (InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue
then Just $ Object resultMap
then Just $ In.Object resultMap
else Nothing
where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
@ -81,7 +82,7 @@ instance VariableValue Aeson.Value where
pure (newObjectValue, insert coerced)
Nothing -> Just (objectValue, resultMap)
coerceVariableValue (ListInputTypeDefinition listType) value
| (Aeson.Array arrayValue) <- value = List
| (Aeson.Array arrayValue) <- value = In.List
<$> foldr foldVector (Just []) arrayValue
| otherwise = coerceVariableValue listType value
where
@ -95,7 +96,7 @@ instance VariableValue Aeson.Value where
-- corresponding types.
coerceInputLiterals
:: HashMap Name InputType
-> HashMap Name Value
-> HashMap Name In.Value
-> Maybe Subs
coerceInputLiterals variableTypes variableValues =
foldWithKey operator variableTypes
@ -105,34 +106,34 @@ coerceInputLiterals variableTypes variableValues =
<$> (lookupVariable variableName >>= coerceInputLiteral variableType)
<*> resultMap
coerceInputLiteral (ScalarInputType type') value
| (String stringValue) <- value
, (ScalarType "String" _) <- type' = Just $ String stringValue
| (Boolean booleanValue) <- value
, (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue
| (Int intValue) <- value
, (ScalarType "Int" _) <- type' = Just $ Int intValue
| (Float floatValue) <- value
, (ScalarType "Float" _) <- type' = Just $ Float floatValue
| (Int intValue) <- value
| (In.String stringValue) <- value
, (ScalarType "String" _) <- type' = Just $ In.String stringValue
| (In.Boolean booleanValue) <- value
, (ScalarType "Boolean" _) <- type' = Just $ In.Boolean booleanValue
| (In.Int intValue) <- value
, (ScalarType "Int" _) <- type' = Just $ In.Int intValue
| (In.Float floatValue) <- value
, (ScalarType "Float" _) <- type' = Just $ In.Float floatValue
| (In.Int intValue) <- value
, (ScalarType "Float" _) <- type' =
Just $ Float $ fromIntegral intValue
| (String stringValue) <- value
, (ScalarType "ID" _) <- type' = Just $ String stringValue
| (Int intValue) <- value
Just $ In.Float $ fromIntegral intValue
| (In.String stringValue) <- value
, (ScalarType "ID" _) <- type' = Just $ In.String stringValue
| (In.Int intValue) <- value
, (ScalarType "ID" _) <- type' = Just $ decimal intValue
coerceInputLiteral (EnumInputType type') (Enum enumValue)
| member enumValue type' = Just $ Enum enumValue
coerceInputLiteral (ObjectInputType type') (Object _) =
coerceInputLiteral (EnumInputType type') (In.Enum enumValue)
| member enumValue type' = Just $ In.Enum enumValue
coerceInputLiteral (ObjectInputType type') (In.Object _) =
let (InputObjectType _ _ inputFields) = type'
in Object <$> foldWithKey matchFieldValues inputFields
in In.Object <$> foldWithKey matchFieldValues inputFields
coerceInputLiteral _ _ = Nothing
member value (EnumType _ _ members) = Set.member value members
matchFieldValues fieldName (InputField _ type' defaultValue) resultMap =
case lookupVariable fieldName of
Just Null
Just In.Null
| isNonNullInputType type' -> Nothing
| otherwise ->
HashMap.insert fieldName Null <$> resultMap
HashMap.insert fieldName In.Null <$> resultMap
Just variableValue -> HashMap.insert fieldName
<$> coerceInputLiteral type' variableValue
<*> resultMap
@ -144,7 +145,7 @@ coerceInputLiterals variableTypes variableValues =
| otherwise -> resultMap
lookupVariable = flip HashMap.lookup variableValues
foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty)
decimal = String
decimal = In.String
. Text.Lazy.toStrict
. Text.Builder.toLazyText
. 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.Type.Definition as Definition
import qualified Language.GraphQL.Type.Directive as Directive
import qualified Language.GraphQL.Type.In as In
import Language.GraphQL.Type.Schema
-- | Associates a fragment name with a list of 'Core.Field's.
@ -136,23 +137,23 @@ coerceVariableValues schema operationDefinition variableValues' =
<*> coercedValues
choose Nothing defaultValue variableType
| Just _ <- defaultValue = defaultValue
| not (isNonNullInputType variableType) = Just Core.Null
| not (isNonNullInputType variableType) = Just In.Null
choose (Just value') _ variableType
| Just coercedValue <- coerceVariableValue variableType value'
, not (isNonNullInputType variableType) || coercedValue /= Core.Null =
, not (isNonNullInputType variableType) || coercedValue /= In.Null =
Just coercedValue
choose _ _ _ = Nothing
constValue :: Full.ConstValue -> Core.Value
constValue (Full.ConstInt i) = Core.Int i
constValue (Full.ConstFloat f) = Core.Float f
constValue (Full.ConstString x) = Core.String x
constValue (Full.ConstBoolean b) = Core.Boolean b
constValue Full.ConstNull = Core.Null
constValue (Full.ConstEnum e) = Core.Enum e
constValue (Full.ConstList l) = Core.List $ constValue <$> l
constValue :: Full.ConstValue -> In.Value
constValue (Full.ConstInt i) = In.Int i
constValue (Full.ConstFloat f) = In.Float f
constValue (Full.ConstString x) = In.String x
constValue (Full.ConstBoolean b) = In.Boolean b
constValue Full.ConstNull = In.Null
constValue (Full.ConstEnum e) = In.Enum e
constValue (Full.ConstList l) = In.List $ constValue <$> l
constValue (Full.ConstObject o) =
Core.Object $ HashMap.fromList $ constObjectField <$> o
In.Object $ HashMap.fromList $ constObjectField <$> o
where
constObjectField (Full.ObjectField key value') = (key, constValue value')
@ -294,19 +295,19 @@ arguments = fmap Core.Arguments . foldM go HashMap.empty
substitutedValue <- value value'
return $ HashMap.insert name substitutedValue arguments'
value :: Full.Value -> TransformT Core.Value
value :: Full.Value -> TransformT In.Value
value (Full.Variable name) =
gets $ fromMaybe Core.Null . HashMap.lookup name . variableValues
value (Full.Int i) = pure $ Core.Int i
value (Full.Float f) = pure $ Core.Float f
value (Full.String x) = pure $ Core.String x
value (Full.Boolean b) = pure $ Core.Boolean b
value Full.Null = pure Core.Null
value (Full.Enum e) = pure $ Core.Enum e
gets $ fromMaybe In.Null . HashMap.lookup name . variableValues
value (Full.Int i) = pure $ In.Int i
value (Full.Float f) = pure $ In.Float f
value (Full.String x) = pure $ In.String x
value (Full.Boolean b) = pure $ In.Boolean b
value Full.Null = pure In.Null
value (Full.Enum e) = pure $ In.Enum e
value (Full.List l) =
Core.List <$> traverse value l
In.List <$> traverse value l
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'

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

@ -1,3 +1,4 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to
@ -8,10 +9,6 @@ module Language.GraphQL.Schema
, object
, resolve
, resolversToMap
, wrappedObject
-- * AST Reexports
, Field
, Value(..)
) where
import Control.Monad.Trans.Class (lift)
@ -28,38 +25,35 @@ import qualified Data.Text as T
import Language.GraphQL.AST.Core
import Language.GraphQL.Error
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
-- information (if an error has occurred). @m@ is an arbitrary monad, usually
-- 'IO'.
data Resolver m = Resolver Name (Definition.FieldResolver m)
-- information (if an error has occurred). @m@ is an arbitrary monad, usually
-- 'IO'.
--
-- Resolving a field can result in a leaf value or an object, which is
-- represented as a list of nested resolvers, used to resolve the fields of that
-- object.
data Resolver m = Resolver Name (ActionT m (Out.Value m))
-- | Converts resolvers to a map.
resolversToMap :: (Foldable f, Functor f)
=> f (Resolver m)
-> HashMap Text (Definition.FieldResolver m)
=> forall m
. 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 Value
type Subs = HashMap Name In.Value
-- | Like 'object' but can be null or a list of objects.
wrappedObject :: Monad m
=> Name
-> ActionT m (Type.Wrapping (Definition.FieldResolver m))
-> 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
-- | 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 _) =
@ -69,26 +63,25 @@ resolveFieldValue field@(Field _ _ args _) =
withField :: Monad m
=> Field
-> Definition.FieldResolver m
-> ActionT m (Out.Value m)
-> CollectErrsT m Aeson.Object
withField field (Definition.ValueResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver
either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
withField field (Definition.NestingResolver resolver) = do
withField field resolver = do
answer <- lift $ resolveFieldValue field resolver
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
toJSON :: Monad m => Field -> Type.Wrapping (Definition.FieldResolver m) -> CollectErrsT m Aeson.Value
toJSON _ Type.Null = pure Aeson.Null
toJSON _ (Type.I i) = pure $ Aeson.toJSON i
toJSON _ (Type.B i) = pure $ Aeson.toJSON i
toJSON _ (Type.F i) = pure $ Aeson.toJSON i
toJSON _ (Type.E i) = pure $ Aeson.toJSON i
toJSON _ (Type.S i) = pure $ Aeson.toJSON i
toJSON field (Type.List list) = Aeson.toJSON <$> traverse (toJSON field) list
toJSON (Field _ _ _ seqSelection) (Type.O map') = map' `resolve` seqSelection
toJSON :: Monad m => Field -> Out.Value m -> CollectErrsT m Aeson.Value
toJSON _ Out.Null = pure Aeson.Null
toJSON _ (Out.Int integer) = pure $ Aeson.toJSON integer
toJSON _ (Out.Boolean boolean) = pure $ Aeson.Bool boolean
toJSON _ (Out.Float float) = pure $ Aeson.toJSON float
toJSON _ (Out.Enum enum) = pure $ Aeson.String enum
toJSON _ (Out.String string) = pure $ Aeson.String string
toJSON field (Out.List list) = Aeson.toJSON <$> traverse (toJSON field) list
toJSON (Field _ _ _ seqSelection) (Out.Object map') =
map' `resolve` seqSelection
errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value)
errmsg field errorMessage = do
@ -96,10 +89,10 @@ errmsg field errorMessage = do
pure $ HashMap.singleton (aliasOrName field) Aeson.Null
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
resolve :: Monad m
=> HashMap Text (Definition.FieldResolver m)
=> HashMap Text (ActionT m (Out.Value m))
-> Seq Selection
-> CollectErrsT m Aeson.Value
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
| otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
tryResolvers (SelectionFragment (Fragment typeCondition selections'))
| Just (Definition.ValueResolver 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
| Just resolver <- lookupResolver "__typename" = do
let fakeField = Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue fakeField resolver
case that of
Right (Type.S typeCondition')
Right (Out.String typeCondition')
| typeCondition' == typeCondition ->
fmap fold . traverse tryResolvers $ selections'
_ -> 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.Text (Text)
import Language.GraphQL.AST.Core
import qualified Language.GraphQL.Type.In as In
import Prelude hiding (lookup)
-- | Resolution context holds resolver arguments.
@ -55,11 +56,11 @@ instance Monad m => MonadPlus (ActionT m) where
mplus = (<|>)
-- | Retrieves an argument by its name. If the argument with this name couldn't
-- be found, returns 'Value.Null' (i.e. the argument is assumed to
-- be found, returns 'In.Null' (i.e. the argument is assumed to
-- be optional then).
argument :: Monad m => Name -> ActionT m Value
argument :: Monad m => Name -> ActionT m In.Value
argument argumentName = do
argumentValue <- ActionT $ lift $ asks $ lookup . arguments
pure $ fromMaybe Null argumentValue
pure $ fromMaybe In.Null argumentValue
where
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(..)
, EnumType(..)
, Field(..)
, FieldResolver(..)
, InputField(..)
, InputObjectType(..)
, InputType(..)
@ -31,13 +30,13 @@ module Language.GraphQL.Type.Definition
, string
) where
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import Data.Set (Set)
import Data.Text (Text)
import Language.GraphQL.AST.Core (Name, Value)
import Language.GraphQL.AST.Document (Name)
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)
-- | Object type definition.
@ -51,17 +50,10 @@ data Field m = Field
(Maybe Text) -- ^ Description.
(OutputType m) -- ^ Field type.
(HashMap Name Argument) -- ^ Arguments.
(FieldResolver 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)))
(ActionT m (Out.Value m)) -- ^ Resolver.
-- | Field argument definition.
data Argument = Argument (Maybe Text) InputType (Maybe Value)
data Argument = Argument (Maybe Text) InputType (Maybe In.Value)
-- | Scalar type definition.
--
@ -77,7 +69,7 @@ data ScalarType = ScalarType Name (Maybe Text)
data EnumType = EnumType Name (Maybe Text) (Set Text)
-- | 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.
--

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 Language.GraphQL.AST.Core
import qualified Language.GraphQL.Type.In as In
-- | Directive processing status.
data Status
@ -36,7 +37,7 @@ skip = handle skip'
where
skip' directive'@(Directive "skip" (Arguments arguments)) =
case HashMap.lookup "if" arguments of
(Just (Boolean True)) -> Skip
(Just (In.Boolean True)) -> Skip
_ -> Include directive'
skip' directive' = Continue directive'
@ -45,6 +46,6 @@ include = handle include'
where
include' directive'@(Directive "include" (Arguments arguments)) =
case HashMap.lookup "if" arguments of
(Just (Boolean True)) -> Include directive'
(Just (In.Boolean True)) -> Include directive'
_ -> Skip
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.Schema
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
import Prelude hiding (id)
import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
@ -22,12 +23,12 @@ direction :: EnumType
direction = EnumType "Direction" Nothing
$ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"]
coerceInputLiteral :: InputType -> Value -> Maybe Subs
coerceInputLiteral :: InputType -> In.Value -> Maybe Subs
coerceInputLiteral input value = coerceInputLiterals
(HashMap.singleton "variableName" input)
(HashMap.singleton "variableName" value)
lookupActual :: Maybe (HashMap Name Value) -> Maybe Value
lookupActual :: Maybe (HashMap Name In.Value) -> Maybe In.Value
lookupActual = (HashMap.lookup "variableName" =<<)
singletonInputObject :: InputType
@ -41,22 +42,22 @@ spec :: Spec
spec = do
describe "ToGraphQL Aeson" $ do
it "coerces strings" $
let expected = Just (String "asdf")
let expected = Just (In.String "asdf")
actual = coerceVariableValue
(ScalarInputType string) (Aeson.String "asdf")
in actual `shouldBe` expected
it "coerces non-null strings" $
let expected = Just (String "asdf")
let expected = Just (In.String "asdf")
actual = coerceVariableValue
(NonNullScalarInputType string) (Aeson.String "asdf")
in actual `shouldBe` expected
it "coerces booleans" $
let expected = Just (Boolean True)
let expected = Just (In.Boolean True)
actual = coerceVariableValue
(ScalarInputType boolean) (Aeson.Bool True)
in actual `shouldBe` expected
it "coerces zero to an integer" $
let expected = Just (Int 0)
let expected = Just (In.Int 0)
actual = coerceVariableValue
(ScalarInputType int) (Aeson.Number 0)
in actual `shouldBe` expected
@ -65,24 +66,24 @@ spec = do
(ScalarInputType int) (Aeson.Number $ scientific 14 (-1))
in actual `shouldSatisfy` isNothing
it "coerces float numbers" $
let expected = Just (Float 1.4)
let expected = Just (In.Float 1.4)
actual = coerceVariableValue
(ScalarInputType float) (Aeson.Number $ scientific 14 (-1))
in actual `shouldBe` expected
it "coerces IDs" $
let expected = Just (String "1234")
let expected = Just (In.String "1234")
actual = coerceVariableValue
(ScalarInputType id) (Aeson.String "1234")
in actual `shouldBe` expected
it "coerces input objects" $
let actual = coerceVariableValue singletonInputObject
$ 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
it "skips the field if it is missing in the variables" $
let actual = coerceVariableValue
singletonInputObject Aeson.emptyObject
expected = Just $ Object HashMap.empty
expected = Just $ In.Object HashMap.empty
in actual `shouldBe` expected
it "fails if input object value contains extra fields" $
let actual = coerceVariableValue singletonInputObject
@ -94,25 +95,25 @@ spec = do
in actual `shouldSatisfy` isNothing
it "preserves null" $
let actual = coerceVariableValue (ScalarInputType id) Aeson.Null
in actual `shouldBe` Just Null
in actual `shouldBe` Just In.Null
it "preserves list order" $
let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
listType = (ListInputType $ ScalarInputType string)
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
describe "coerceInputLiterals" $ do
it "coerces enums" $
let expected = Just (Enum "NORTH")
let expected = Just (In.Enum "NORTH")
actual = coerceInputLiteral
(EnumInputType direction) (Enum "NORTH")
(EnumInputType direction) (In.Enum "NORTH")
in lookupActual actual `shouldBe` expected
it "fails with non-existing enum value" $
let actual = coerceInputLiteral
(EnumInputType direction) (Enum "NORTH_EAST")
(EnumInputType direction) (In.Enum "NORTH_EAST")
in actual `shouldSatisfy` isNothing
it "coerces integers to IDs" $
let expected = Just (String "1234")
actual = coerceInputLiteral (ScalarInputType id) (Int 1234)
let expected = Just (In.String "1234")
actual = coerceInputLiteral (ScalarInputType id) (In.Int 1234)
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.Error
import Language.GraphQL.Schema
import qualified Language.GraphQL.Type as Type
import Language.GraphQL.Type.Definition
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 = NestingResolver $ pure $ object
[ wrappedObject "field" $ pure $ Type.S "T"
let resolver = pure $ object
[ Resolver "field" $ pure $ Out.String "T"
]
schema = HashMap.singleton "__typename" resolver
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 Language.GraphQL
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema(..))
import Test.Hspec (Spec, describe, it, shouldBe)
import Text.RawString.QQ (r)
@ -15,7 +16,7 @@ import Text.RawString.QQ (r)
experimentalResolver :: Schema IO
experimentalResolver = Schema { query = queryType, mutation = Nothing }
where
resolver = ValueResolver $ pure $ Number 5
resolver = pure $ Out.Int 5
queryType = ObjectType "Query" Nothing
$ HashMap.singleton "experimentalField"
$ 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 Language.GraphQL
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
( Spec
, describe
@ -17,21 +19,19 @@ import Test.Hspec
, shouldBe
, shouldNotSatisfy
)
import Language.GraphQL.Type.Definition
import Language.GraphQL.Type.Schema
import Text.RawString.QQ (r)
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.wrappedObject "circumference" $ pure $ Type.I 60
circumference = Schema.Resolver "circumference" $ pure $ Out.Int 60
garment :: Text -> Schema.Resolver IO
garment typeName = Schema.wrappedObject "garment"
garment typeName = Schema.Resolver "garment"
$ pure $ Schema.object
[ if typeName == "Hat" then circumference else size
, Schema.wrappedObject "__typename" $ pure $ Type.S typeName
, Schema.Resolver "__typename" $ pure $ Out.String typeName
]
inlineQuery :: Text
@ -107,7 +107,7 @@ spec = do
}
}
}|]
resolvers = Schema.wrappedObject "garment"
resolvers = Schema.Resolver "garment"
$ pure $ Schema.object [circumference, size]
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 Text.RawString.QQ (r)
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
import qualified Language.GraphQL.Type as Type
hatType :: ObjectType IO
hatType = ObjectType "Hat" Nothing
@ -20,20 +20,19 @@ hatType = ObjectType "Hat" Nothing
$ Field Nothing (ScalarOutputType int) mempty resolve
where
(Schema.Resolver resolverName resolve) =
Schema.wrappedObject "circumference" $ pure $ Type.I 60
Schema.Resolver "circumference" $ pure $ Out.Int 60
schema :: Schema IO
schema = Schema
(ObjectType "Query" Nothing hatField)
(Just $ ObjectType "Mutation" Nothing incrementField)
where
garment = NestingResolver
$ pure $ Schema.object
[ Schema.wrappedObject "circumference" $ pure $ Type.I 60
garment = pure $ Schema.object
[ Schema.Resolver "circumference" $ pure $ Out.Int 60
]
incrementField = HashMap.singleton "incrementCircumference"
$ Field Nothing (ScalarOutputType int) mempty
$ NestingResolver $ pure $ Type.I 61
$ pure $ Out.Int 61
hatField = HashMap.singleton "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 Language.GraphQL.Trans
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 Test.StarWars.Data
@ -30,45 +31,45 @@ schema = Schema { query = queryType, mutation = Nothing }
, ("droid", Field Nothing (ScalarOutputType string) mempty droid)
]
hero :: FieldResolver Identity
hero = NestingResolver $ do
hero :: ActionT Identity (Out.Value Identity)
hero = do
episode <- argument "episode"
pure $ character $ case episode of
Schema.Enum "NEWHOPE" -> getHero 4
Schema.Enum "EMPIRE" -> getHero 5
Schema.Enum "JEDI" -> getHero 6
In.Enum "NEWHOPE" -> getHero 4
In.Enum "EMPIRE" -> getHero 5
In.Enum "JEDI" -> getHero 6
_ -> artoo
human :: FieldResolver Identity
human = NestingResolver $ do
human :: ActionT Identity (Out.Value Identity)
human = do
id' <- argument "id"
case id' of
Schema.String i -> do
In.String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of
Nothing -> pure Type.Null
Nothing -> pure Out.Null
Just e -> pure $ character e
_ -> ActionT $ throwE "Invalid arguments."
droid :: FieldResolver Identity
droid = NestingResolver $ do
droid :: ActionT Identity (Out.Value Identity)
droid = do
id' <- argument "id"
case id' of
Schema.String i -> getDroid i >>= pure . character
In.String i -> getDroid i >>= pure . character
_ -> ActionT $ throwE "Invalid arguments."
character :: Character -> Type.Wrapping (FieldResolver Identity)
character :: Character -> Out.Value Identity
character char = Schema.object
[ Schema.wrappedObject "id" $ pure $ Type.S $ id_ char
, Schema.wrappedObject "name" $ pure $ Type.S $ name_ char
, Schema.wrappedObject "friends"
$ pure
$ Type.List
$ fmap character
$ getFriends char
, Schema.wrappedObject "appearsIn" $ pure
$ Type.List $ Type.E <$> catMaybes (getEpisode <$> appearsIn char)
, Schema.wrappedObject "secretBackstory" $ Type.S <$> secretBackstory char
, Schema.wrappedObject "homePlanet" $ pure $ Type.S $ either mempty homePlanet char
, Schema.wrappedObject "__typename" $ pure $ Type.S $ typeName char
[ Schema.Resolver "id" $ pure $ Out.String $ id_ char
, Schema.Resolver "name" $ pure $ Out.String $ name_ char
, Schema.Resolver "friends"
$ pure $ Out.List $ fmap character $ getFriends char
, Schema.Resolver "appearsIn" $ pure
$ Out.List $ Out.Enum <$> catMaybes (getEpisode <$> appearsIn 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
]