OSS
/
graphql
1
1
Fork 1
Code Issues 3 Pull Requests Actions Releases 22 Wiki Activity

Define resolvers on type fields 

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
- `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 [...]`.
- `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.Definition.Value`.
- `AST.Core.Value` was moved into `Type.Definition`. These values are used only
in the execution and type system, it is not a part of the parsing tree.
- `Type` module is superseded by `Type.Out`. This module contains now only
exports from other module that complete `Type.In` and `Type.Out` exports.
- `Error.CollectErrsT` contains the new `Resolution` data structure.
`Resolution` represents the state used by the executor. It contains all types
defined in the schema and collects the thrown errors.
### Added
- `Type.Definition` contains base type system definition, e.g. Enums and
@ -43,16 +40,18 @@ and this project adheres to
`Subs`, where a is an instance of `VariableValue`.
### 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
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.
GraphQL. E.g. GraphQL distinguishes between Floats and Integers.
- `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no
need in special functions to construct field resolvers anymore, resolvers are
normal functions attached to the fields in the schema representation.
- `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
### Fixed

8
docs/tutorial/tutorial.lhs
View File

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

1
package.yaml
View File

@ -40,6 +40,7 @@ dependencies:
library:
source-dirs: src
other-modules:
- Language.GraphQL.Execute.Execution
- Language.GraphQL.Execute.Transform
- 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.
module Language.GraphQL.AST.Core
( Alias
, Arguments(..)
, Directive(..)
, Field(..)
, Fragment(..)
( Arguments(..)
, Name
, Operation(..)
, Selection(..)
, TypeCondition
) where
import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq)
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.
--
-- Currently only queries and mutations are supported.
data Operation
= Query (Maybe Text) (Seq Selection)
| Mutation (Maybe Text) (Seq Selection)
deriving (Eq, Show)
-- | Single GraphQL field.
data Field
= Field (Maybe Alias) Name Arguments (Seq Selection)
deriving (Eq, Show)
import Language.GraphQL.AST (Name)
import Language.GraphQL.Type.Definition
-- | Argument list.
newtype Arguments = Arguments (HashMap Name In.Value)
newtype Arguments = Arguments (HashMap Name Value)
deriving (Eq, Show)
instance Semigroup Arguments where
@ -40,17 +18,3 @@ instance Semigroup Arguments where
instance Monoid Arguments where
mempty = Arguments mempty
-- | Directive.
data Directive = Directive Name Arguments
deriving (Eq, Show)
-- | Represents fragments and inline fragments.
data Fragment
= Fragment TypeCondition (Seq Selection)
deriving (Eq, Show)
-- | Single selection element.
data Selection
= SelectionFragment Fragment
| SelectionField Field
deriving (Eq, Show)

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

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

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

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

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

@ -12,12 +12,17 @@
-- replaced by the selection set they represent. Invalid (recursive and
-- non-existing) fragments are skipped. The most fragments are inlined, so the
-- executor doesn't have to perform additional lookups later.
-- * Evaluating directives (@\@include@ and @\@skip@).
--
-- This module is also responsible for smaller rewrites that touch only parts of
-- the original AST.
module Language.GraphQL.Execute.Transform
( Document(..)
, Fragment(..)
, QueryError(..)
, Operation(..)
, Selection(..)
, Field(..)
, document
, queryError
) where
@ -36,26 +41,48 @@ import Data.Sequence (Seq, (<|), (><))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.AST.Core as Core
import Language.GraphQL.AST.Core
import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Schema as Schema
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.Out as Out
import qualified Language.GraphQL.Type.Directive as Core
import Language.GraphQL.Type.Schema
-- | Associates a fragment name with a list of 'Core.Field's.
data Replacement m = Replacement
{ fragments :: HashMap Core.Name Core.Fragment
{ fragments :: HashMap Full.Name (Fragment m)
, fragmentDefinitions :: FragmentDefinitions
, variableValues :: Schema.Subs
, variableValues :: Subs
, types :: HashMap Full.Name (Type m)
}
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.
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
Full.OperationType
@ -131,7 +158,7 @@ coerceVariableValues :: VariableValue a
. HashMap Full.Name (Type m)
-> OperationDefinition
-> HashMap.HashMap Full.Name a
-> Either QueryError Schema.Subs
-> Either QueryError Subs
coerceVariableValues types operationDefinition variableValues' =
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
in maybe (Left CoercionError) Right
@ -149,23 +176,23 @@ coerceVariableValues types operationDefinition variableValues' =
<*> coercedValues
choose Nothing defaultValue variableType
| Just _ <- defaultValue = defaultValue
| not (In.isNonNullType variableType) = Just In.Null
| not (In.isNonNullType variableType) = Just Null
choose (Just value') _ variableType
| Just coercedValue <- coerceVariableValue variableType value'
, not (In.isNonNullType variableType) || coercedValue /= In.Null =
, not (In.isNonNullType variableType) || coercedValue /= Null =
Just coercedValue
choose _ _ _ = Nothing
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.ConstValue -> Value
constValue (Full.ConstInt i) = Int i
constValue (Full.ConstFloat f) = Float f
constValue (Full.ConstString x) = String x
constValue (Full.ConstBoolean b) = Boolean b
constValue Full.ConstNull = Null
constValue (Full.ConstEnum e) = Enum e
constValue (Full.ConstList l) = List $ constValue <$> l
constValue (Full.ConstObject o) =
In.Object $ HashMap.fromList $ constObjectField <$> o
Object $ HashMap.fromList $ constObjectField <$> o
where
constObjectField (Full.ObjectField key value') = (key, constValue value')
@ -193,12 +220,12 @@ document schema operationName subs ast = do
}
case chosenOperation of
OperationDefinition Full.Query _ _ _ _ ->
pure $ Document (query schema)
$ operation (query schema) chosenOperation replacement
pure $ Document referencedTypes (query schema)
$ operation chosenOperation replacement
OperationDefinition Full.Mutation _ _ _ _
| Just mutationType <- mutation schema ->
pure $ Document mutationType
$ operation mutationType chosenOperation replacement
pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement
_ -> Left UnsupportedRootOperation
defragment
@ -227,72 +254,73 @@ defragment ast =
-- * Operation
operation :: forall m
. Out.ObjectType m
-> OperationDefinition
-> Replacement m
-> Core.Operation
operation rootType operationDefinition replacement
operation :: OperationDefinition -> Replacement m -> Operation m
operation operationDefinition replacement
= runIdentity
$ evalStateT (collectFragments rootType >> transform operationDefinition) replacement
$ evalStateT (collectFragments >> transform operationDefinition) replacement
where
transform (OperationDefinition Full.Query name _ _ sels) =
Core.Query name <$> appendSelection sels rootType
Query name <$> appendSelection sels
transform (OperationDefinition Full.Mutation name _ _ sels) =
Core.Mutation name <$> appendSelection sels rootType
Mutation name <$> appendSelection sels
-- * Selection
selection :: forall m
. Full.Selection
-> Out.ObjectType m
-> State (Replacement m) (Either (Seq Core.Selection) Core.Selection)
selection (Full.Field alias name arguments' directives' selections) objectType =
maybe (Left mempty) (Right . Core.SelectionField) <$> do
selection
:: Full.Selection
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
selection (Full.Field alias name arguments' directives' selections) =
maybe (Left mempty) (Right . SelectionField) <$> do
fieldArguments <- arguments arguments'
fieldSelections <- appendSelection selections objectType
fieldSelections <- appendSelection selections
fieldDirectives <- Directive.selection <$> directives directives'
let field' = Core.Field alias name fieldArguments fieldSelections
let field' = Field alias name fieldArguments fieldSelections
pure $ field' <$ fieldDirectives
selection (Full.FragmentSpread name directives') objectType =
maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
selection (Full.FragmentSpread name directives') =
maybe (Left mempty) (Right . SelectionFragment) <$> do
spreadDirectives <- Directive.selection <$> directives directives'
fragments' <- gets fragments
fragmentDefinitions' <- gets fragmentDefinitions
case HashMap.lookup name fragments' of
Just definition -> lift $ pure $ definition <$ spreadDirectives
Nothing -> case HashMap.lookup name fragmentDefinitions' of
Just definition -> do
fragment <- fragmentDefinition definition objectType
lift $ pure $ fragment <$ spreadDirectives
Nothing -> lift $ pure Nothing
selection (Full.InlineFragment type' directives' selections) objectType = do
Nothing
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
fragDef <- fragmentDefinition definition
case fragDef of
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
_ -> lift $ pure Nothing
| otherwise -> lift $ pure Nothing
selection (Full.InlineFragment type' directives' selections) = do
fragmentDirectives <- Directive.selection <$> directives directives'
case fragmentDirectives of
Nothing -> pure $ Left mempty
_ -> do
fragmentSelectionSet <- appendSelection selections objectType
pure $ maybe Left selectionFragment type' fragmentSelectionSet
fragmentSelectionSet <- appendSelection selections
case type' of
Nothing -> pure $ Left fragmentSelectionSet
Just typeName -> do
typeCondition' <- lookupTypeCondition typeName
case typeCondition' of
Just typeCondition -> pure $
selectionFragment typeCondition fragmentSelectionSet
Nothing -> pure $ Left mempty
where
selectionFragment typeName = Right
. Core.SelectionFragment
. Core.Fragment typeName
. SelectionFragment
. Fragment typeName
appendSelection :: Traversable t
=> forall m
. t Full.Selection
-> Out.ObjectType m
-> State (Replacement m) (Seq Core.Selection)
appendSelection selectionSet objectType = foldM go mempty selectionSet
=> t Full.Selection
-> State (Replacement m) (Seq (Selection m))
appendSelection = foldM go mempty
where
go acc sel = append acc <$> selection sel objectType
go acc sel = append acc <$> selection sel
append acc (Left list) = list >< acc
append acc (Right one) = one <| acc
directives :: forall m
. [Full.Directive]
-> State (Replacement m) [Core.Directive]
directives :: [Full.Directive] -> State (Replacement m) [Core.Directive]
directives = traverse directive
where
directive (Full.Directive directiveName directiveArguments) =
@ -301,24 +329,40 @@ directives = traverse directive
-- * Fragment replacement
-- | Extract fragment definitions into a single 'HashMap'.
collectFragments :: forall m. Out.ObjectType m -> State (Replacement m) ()
collectFragments objectType = do
collectFragments :: State (Replacement m) ()
collectFragments = do
fragDefs <- gets fragmentDefinitions
let nextValue = head $ HashMap.elems fragDefs
unless (HashMap.null fragDefs) $ do
_ <- fragmentDefinition nextValue objectType
collectFragments objectType
_ <- fragmentDefinition nextValue
collectFragments
fragmentDefinition :: forall m
. Full.FragmentDefinition
-> Out.ObjectType m
-> State (Replacement m) Core.Fragment
fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType = do
lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m))
lookupTypeCondition type' = do
types' <- gets types
case HashMap.lookup type' types' of
Just (ObjectType objectType) ->
lift $ pure $ Just $ CompositeObjectType objectType
Just (UnionType unionType) ->
lift $ pure $ Just $ CompositeUnionType unionType
Just (InterfaceType interfaceType) ->
lift $ pure $ Just $ CompositeInterfaceType interfaceType
_ -> lift $ pure Nothing
fragmentDefinition
:: Full.FragmentDefinition
-> State (Replacement m) (Maybe (Fragment m))
fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
modify deleteFragmentDefinition
fragmentSelection <- appendSelection selections objectType
let newValue = Core.Fragment type' fragmentSelection
modify $ insertFragment newValue
lift $ pure newValue
fragmentSelection <- appendSelection selections
compositeType <- lookupTypeCondition type'
case compositeType of
Just compositeType' -> do
let newValue = Fragment compositeType' fragmentSelection
modify $ insertFragment newValue
lift $ pure $ Just newValue
_ -> lift $ pure Nothing
where
deleteFragmentDefinition replacement@Replacement{..} =
let newDefinitions = HashMap.delete name fragmentDefinitions
@ -327,27 +371,27 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType
let newFragments = HashMap.insert name newValue fragments
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
where
go arguments' (Full.Argument name value') = do
substitutedValue <- value value'
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) =
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) = In.List <$> traverse value l
gets $ fromMaybe Null . HashMap.lookup name . variableValues
value (Full.Int i) = pure $ Int i
value (Full.Float f) = pure $ Float f
value (Full.String x) = pure $ String x
value (Full.Boolean b) = pure $ Boolean b
value Full.Null = pure Null
value (Full.Enum e) = pure $ Enum e
value (Full.List l) = List <$> traverse value l
value (Full.Object o) =
In.Object . HashMap.fromList <$> traverse objectField o
Object . HashMap.fromList <$> traverse objectField o
objectField :: forall m
. Full.ObjectField Full.Value
-> State (Replacement m) (Core.Name, In.Value)
objectField
:: Full.ObjectField Full.Value
-> State (Replacement m) (Full.Name, 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.
module Language.GraphQL.Schema
( Resolver(..)
, Subs
, object
, resolve
, resolversToMap
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (fold, toList)
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq)
import qualified Data.Map.Strict as Map
import Data.Sequence (Seq(..))
import Data.Text (Text)
import qualified Data.Text as T
import Language.GraphQL.AST.Core
import qualified Data.Text as Text
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Error
import Language.GraphQL.Execute.Execution
import Language.GraphQL.Execute.Transform
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
-- | 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
-- 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))
data Resolver m = Resolver Name (ActionT m Value)
-- | Converts resolvers to a map.
resolversToMap :: (Foldable f, Functor f)
=> 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 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})
resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
resolveFieldValue result (Field _ _ args _) =
flip runReaderT (Context {arguments=args, values=result})
. runExceptT
. runActionT
withField :: Monad m
=> Field
-> ActionT m (Out.Value m)
-> CollectErrsT m Aeson.Object
withField field resolver = do
answer <- lift $ resolveFieldValue field resolver
executeField :: Monad m
=> Value
-> Out.Field m
-> Field m
-> CollectErrsT m Aeson.Value
executeField prev (Out.Field _ fieldType _ resolver) field = do
answer <- lift $ resolveFieldValue prev field resolver
case answer of
Right result -> HashMap.singleton (aliasOrName field)
<$> toJSON field result
Left errorMessage -> errmsg field errorMessage
Right result -> completeValue fieldType field result
Left errorMessage -> errmsg errorMessage
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
completeValue :: Monad m
=> Out.Type m
-> Field m
-> Value
-> CollectErrsT m Aeson.Value
completeValue _ _ Null = pure Aeson.Null
completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
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 field errorMessage = do
addErrMsg errorMessage
pure $ HashMap.singleton (aliasOrName field) Aeson.Null
errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
errmsg errorMessage = addErrMsg errorMessage >> pure 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.
resolve :: Monad m
=> HashMap Text (ActionT m (Out.Value m))
-> Seq Selection
resolve :: Monad m -- executeSelectionSet
=> Value
-> Out.ObjectType m
-> Seq (Selection m)
-> 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
forEach _responseKey (field :<| _) =
tryResolvers field >>= lift . pure . pure
forEach _ _ = pure Nothing
lookupResolver = flip HashMap.lookup resolvers
tryResolvers (SelectionField fld@(Field _ name _ _))
| (Just resolver) <- lookupResolver name = withField fld resolver
| otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
tryResolvers (SelectionFragment (Fragment typeCondition selections'))
| Just resolver <- lookupResolver "__typename" = do
let fakeField = Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue fakeField resolver
tryResolvers fld@(Field _ name _ _)
| Just typeField <- lookupResolver name =
executeField result typeField fld
| otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
{-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections'))
| Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do
let fakeField = Out.Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue result fakeField resolver
case that of
Right (Out.String typeCondition')
| typeCondition' == typeCondition ->
Right (String typeCondition')
| (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition
, typeCondition' == n ->
fmap fold . traverse tryResolvers $ selections'
_ -> pure mempty
| otherwise = fmap fold . traverse tryResolvers $ selections'
aliasOrName :: Field -> Text
aliasOrName (Field alias name _ _) = fromMaybe name alias
| otherwise = fmap fold . traverse tryResolvers $ selections'-}

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

@ -1,8 +1,8 @@
-- | Monad transformer stack used by the @GraphQL@ resolvers.
module Language.GraphQL.Trans
( ActionT(..)
( argument
, ActionT(..)
, Context(..)
, argument
) where
import Control.Applicative (Alternative(..))
@ -15,13 +15,13 @@ 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 Language.GraphQL.Type.Definition
import Prelude hiding (lookup)
-- | Resolution context holds resolver arguments.
data Context = Context
{ arguments :: Arguments
, info :: Field
, values :: Value
}
-- | Monad transformer stack used by the resolvers to provide error handling
@ -56,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 'In.Null' (i.e. the argument is assumed to
-- be found, returns 'Null' (i.e. the argument is assumed to
-- be optional then).
argument :: Monad m => Name -> ActionT m In.Value
argument :: Monad m => Name -> ActionT m Value
argument argumentName = do
argumentValue <- ActionT $ lift $ asks $ lookup . arguments
pure $ fromMaybe In.Null argumentValue
pure $ fromMaybe Null argumentValue
where
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
( EnumType(..)
, ScalarType(..)
, Subs
, Value(..)
, boolean
, float
, id
@ -11,11 +13,33 @@ module Language.GraphQL.Type.Definition
, string
) where
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import Data.Set (Set)
import Data.String (IsString(..))
import Data.Text (Text)
import Language.GraphQL.AST.Document (Name)
import Prelude hiding (id)
-- | Represents accordingly typed GraphQL values.
data Value
= Int Int32
| Float Double -- ^ GraphQL Float is double precision.
| String Text
| Boolean Bool
| Null
| Enum Name
| List [Value] -- ^ Arbitrary nested list.
| Object (HashMap Name Value)
deriving (Eq, Show)
instance IsString Value where
fromString = String . fromString
-- | Contains variables for the query. The key of the map is a variable name,
-- and the value is the variable value.
type Subs = HashMap Name Value
-- | Scalar type definition.
--
-- The leaf values of any request and input values to arguments are Scalars (or

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

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

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

@ -10,7 +10,6 @@ module Language.GraphQL.Type.In
, InputField(..)
, InputObjectType(..)
, Type(..)
, Value(..)
, isNonNullType
, pattern EnumBaseType
, pattern ListBaseType
@ -19,8 +18,6 @@ module Language.GraphQL.Type.In
) where
import Data.HashMap.Strict (HashMap)
import Data.Int (Int32)
import Data.String (IsString(..))
import Data.Text (Text)
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Type.Definition
@ -36,6 +33,10 @@ data InputObjectType = InputObjectType
Name (Maybe Text) (HashMap Name InputField)
-- | These types may be used as input types for arguments and directives.
--
-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
-- type can wrap other wrapping or named types. Wrapping types are lists and
-- Non-Null types (named types are nullable by default).
data Type
= NamedScalarType ScalarType
| NamedEnumType EnumType
@ -46,21 +47,6 @@ data Type
| NonNullInputObjectType InputObjectType
| 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.
data Argument = Argument (Maybe Text) Type (Maybe Value)

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

@ -1,5 +1,4 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
@ -13,7 +12,6 @@ module Language.GraphQL.Type.Out
, ObjectType(..)
, Type(..)
, UnionType(..)
, Value(..)
, isNonNullType
, pattern EnumBaseType
, pattern InterfaceBaseType
@ -24,12 +22,8 @@ module Language.GraphQL.Type.Out
) 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.AST.Core
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
@ -60,9 +54,13 @@ data Field m = Field
(Maybe Text) -- ^ Description.
(Type m) -- ^ Field type.
(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.
--
-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
-- type can wrap other wrapping or named types. Wrapping types are lists and
-- Non-Null types (named types are nullable by default).
data Type m
= NamedScalarType ScalarType
| NamedEnumType EnumType
@ -77,48 +75,6 @@ data Type m
| NonNullUnionType (UnionType 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'.
pattern ScalarBaseType :: forall m. ScalarType -> Type m
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)

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

@ -2,14 +2,15 @@
-- | Schema Definition.
module Language.GraphQL.Type.Schema
( Schema(..)
( CompositeType(..)
, Schema(..)
, Type(..)
, collectReferencedTypes
) where
import Data.HashMap.Strict (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.In as In
import qualified Language.GraphQL.Type.Out as Out
@ -23,6 +24,12 @@ data Type m
| InterfaceType (Out.InterfaceType 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,
-- query and mutation (optional). A schema definition is then supplied to the
-- validator and executor.

2
stack.yaml
View File

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

7
tests/Test/DirectiveSpec.hs
View File

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

84
tests/Test/FragmentSpec.hs
View File

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

15
tests/Test/RootOperationSpec.hs
View File

@ -7,7 +7,6 @@ module Test.RootOperationSpec
import Data.Aeson ((.=), object)
import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema
import Test.Hspec (Spec, describe, it, shouldBe)
import Text.RawString.QQ (r)
import Language.GraphQL.Type.Definition
@ -16,23 +15,21 @@ import Language.GraphQL.Type.Schema
hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.singleton resolverName
$ Out.Field Nothing (Out.NamedScalarType int) mempty resolve
where
(Schema.Resolver resolverName resolve) =
Schema.Resolver "circumference" $ pure $ Out.Int 60
$ HashMap.singleton "circumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty
$ pure $ Int 60
schema :: Schema IO
schema = Schema
(Out.ObjectType "Query" Nothing [] hatField)
(Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
where
garment = pure $ Schema.object
[ Schema.Resolver "circumference" $ pure $ Out.Int 60
garment = pure $ Object $ HashMap.fromList
[ ("circumference", Int 60)
]
incrementField = HashMap.singleton "incrementCircumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty
$ pure $ Out.Int 61
$ pure $ Int 61
hatField = HashMap.singleton "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 (Right x) = _appearsIn . _humanChar $ x
secretBackstory :: Character -> ActionT Identity Text
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
secretBackstory :: ActionT Identity Text
secretBackstory = ActionT $ throwE "secretBackstory is secret."
typeName :: Character -> Text
typeName = either (const "Droid") (const "Human")

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

@ -1,24 +1,22 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.StarWars.Schema
( character
, droid
, hero
, human
, schema
( schema
) where
import Control.Monad.Trans.Reader (asks)
import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Class (lift)
import Data.Functor.Identity (Identity)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import qualified Language.GraphQL.Schema as Schema
import Data.Text (Text)
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
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
import Prelude hiding (id)
-- 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 }
where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", Out.Field Nothing (Out.NamedScalarType string) mempty hero)
, ("human", Out.Field Nothing (Out.NamedScalarType string) mempty human)
, ("droid", Out.Field Nothing (Out.NamedScalarType string) mempty droid)
[ ("hero", Out.Field Nothing (Out.NamedObjectType heroObject) mempty hero)
, ("human", Out.Field Nothing (Out.NamedObjectType heroObject) mempty human)
, ("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
episode <- argument "episode"
pure $ character $ case episode of
In.Enum "NEWHOPE" -> getHero 4
In.Enum "EMPIRE" -> getHero 5
In.Enum "JEDI" -> getHero 6
Enum "NEWHOPE" -> getHero 4
Enum "EMPIRE" -> getHero 5
Enum "JEDI" -> getHero 6
_ -> artoo
human :: ActionT Identity (Out.Value Identity)
human :: ActionT Identity Value
human = do
id' <- argument "id"
case id' of
In.String i -> do
String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of
Nothing -> pure Out.Null
Nothing -> pure Null
Just e -> pure $ character e
_ -> ActionT $ throwE "Invalid arguments."
droid :: ActionT Identity (Out.Value Identity)
droid :: ActionT Identity Value
droid = do
id' <- argument "id"
case id' of
In.String i -> character <$> getDroid i
String i -> character <$> getDroid i
_ -> ActionT $ throwE "Invalid arguments."
character :: Character -> Out.Value Identity
character char = Schema.object
[ Schema.Resolver "id" $ pure $ Out.String $ id_ char
, Schema.Resolver "name" $ pure $ Out.String $ name_ char
, Schema.Resolver "friends"
$ pure $ Out.List $ 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
character :: Character -> Value
character char = Object $ HashMap.fromList
[ ("id", String $ id_ char)
, ("name", String $ name_ char)
, ("friends", List $ character <$> getFriends char)
, ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
, ("homePlanet", String $ either mempty homePlanet char)
, ("__typename", String $ typeName char)
]