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:
parent
c06d0b8e95
commit
d12577ae71
33
CHANGELOG.md
33
CHANGELOG.md
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -40,6 +40,7 @@ dependencies:
|
||||
library:
|
||||
source-dirs: src
|
||||
other-modules:
|
||||
- Language.GraphQL.Execute.Execution
|
||||
- Language.GraphQL.Execute.Transform
|
||||
- Language.GraphQL.Type.Directive
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
58
src/Language/GraphQL/Execute/Execution.hs
Normal 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
|
||||
@ -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'
|
||||
|
||||
@ -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'-}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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'
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
resolver: lts-15.13
|
||||
resolver: lts-15.14
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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."
|
||||
|
||||
@ -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 []
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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)
|
||||
]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user