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

Don't fail on invalid fragments and variables

This commit is contained in:
Eugen Wissner 2020-05-23 06:46:21 +02:00
parent 26cc53ce06
commit 7cd4821718
17 changed files with 219 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
CHANGELOG.md
View File

@ -12,6 +12,9 @@ and this project adheres to
specification defines default values as `Value` with `const` parameter and
constant cannot be variables. `AST.Document.ConstValue` was added,
`AST.Document.ObjectField` was modified.
- AST transformation should never fail.
* Missing variable are assumed to be null.
* Invalid (recusrive or non-existing) fragments should be skipped.
### Changed
- `Resolver` is now `Resolver Name FieldResolver` where `FieldResolver` can
@ -36,9 +39,12 @@ and this project adheres to
### Removed
- `AST.Core.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. Therefore `Document` was modified and moved to
`Execute.Transform`. It contains only slightly modified AST used to pick the
operation.
interested only in one of them. Therefore `Document` was modified, moved to
`Execute.Transform` and made private.
- `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.
## [0.7.0.0] - 2020-05-11
### Fixed

34
docs/tutorial/tutorial.lhs
View File

@ -17,14 +17,15 @@ Since this file is a literate haskell file, we start by importing some dependenc
> import Control.Monad.IO.Class (liftIO)
> import Data.Aeson (encode)
> import Data.ByteString.Lazy.Char8 (putStrLn)
> import Data.List.NonEmpty (NonEmpty(..))
> import qualified Data.HashMap.Strict as HashMap
> import Data.Text (Text)
> import qualified Data.Text as Text
> import Data.Time (getCurrentTime)
>
> import Language.GraphQL
> import qualified Language.GraphQL.Schema as Schema
> import Language.GraphQL.Type.Definition
> import Language.GraphQL.Type.Schema
> import qualified Language.GraphQL.Type as Type
>
> import Prelude hiding (putStrLn)
@ -39,12 +40,12 @@ First we build a GraphQL schema.
> schema1 = Schema queryType Nothing
>
> queryType :: ObjectType IO
> queryType = ObjectType "Query"
> $ Field Nothing (ScalarOutputType string) mempty
> <$> Schema.resolversToMap (hello :| [])
> queryType = ObjectType "Query" Nothing
> $ HashMap.singleton "hello"
> $ Field Nothing (ScalarOutputType string) mempty hello
>
> hello :: Schema.Resolver IO
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
> hello :: FieldResolver IO
> hello = NestingResolver $ pure $ Type.S "it's me"
This defines a simple schema with one type and one field, that resolves to a fixed value.
@ -74,14 +75,14 @@ For this example, we're going to be using time.
> schema2 = Schema queryType2 Nothing
>
> queryType2 :: ObjectType IO
> queryType2 = ObjectType "Query"
> $ Field Nothing (ScalarOutputType string) mempty
> <$> Schema.resolversToMap (time :| [])
> queryType2 = ObjectType "Query" Nothing
> $ HashMap.singleton "time"
> $ Field Nothing (ScalarOutputType string) mempty time
>
> time :: Schema.Resolver IO
> time = Schema.scalar "time" $ do
> time :: FieldResolver IO
> time = NestingResolver $ do
> t <- liftIO getCurrentTime
> return $ show t
> pure $ Type.S $ Text.pack $ show t
This defines a simple schema with one type and one field,
which resolves to the current time.
@ -138,9 +139,10 @@ Now that we have two resolvers, we can define a schema which uses them both.
> schema3 = Schema queryType3 Nothing
>
> queryType3 :: ObjectType IO
> queryType3 = ObjectType "Query"
> $ Field Nothing (ScalarOutputType string) mempty
> <$> Schema.resolversToMap (hello :| [time])
> queryType3 = ObjectType "Query" Nothing $ HashMap.fromList
> [ ("hello", Field Nothing (ScalarOutputType string) mempty hello)
> , ("time", Field Nothing (ScalarOutputType string) mempty time)
> ]
>
> query3 :: Text
> query3 = "query timeAndHello { time hello }"

1
package.yaml
View File

@ -35,6 +35,7 @@ dependencies:
- text
- transformers
- unordered-containers
- vector
library:
source-dirs: src

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

@ -54,7 +54,7 @@ document :: (Monad m, VariableValue a)
document schema operationName subs document' =
case Transform.document schema operationName subs document' of
Left queryError -> pure $ singleError $ Transform.queryError queryError
Right (Transform.Document op _) -> operation schema op
Right (Transform.Document operation') -> operation schema operation'
operation :: Monad m
=> Schema m
@ -65,7 +65,8 @@ operation = schemaOperation
resolve queryFields = runCollectErrs
. flip Schema.resolve queryFields
. fmap getResolver
. Definition.fields
. fields
fields (Definition.ObjectType _ _ objectFields) = objectFields
lookupError = pure
$ singleError "Root operation type couldn't be found in the schema."
schemaOperation Schema {query} (AST.Core.Query _ fields') =

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

@ -4,6 +4,7 @@
module Language.GraphQL.Execute.Coerce
( VariableValue(..)
, coerceInputLiterals
, isNonNullInputType
) where
import qualified Data.Aeson as Aeson
@ -148,6 +149,7 @@ coerceInputLiterals variableTypes variableValues =
. Text.Builder.toLazyText
. Text.Builder.decimal
-- | Checks whether the given input type is a non-null type.
isNonNullInputType :: InputType -> Bool
isNonNullInputType (NonNullScalarInputType _) = True
isNonNullInputType (NonNullEnumInputType _) = True

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

@ -15,11 +15,12 @@ module Language.GraphQL.Execute.Transform
import Control.Monad (foldM, unless)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Control.Monad.Trans.State (State, evalStateT, gets, modify)
import Data.Foldable (find)
import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq, (<|), (><))
@ -37,17 +38,13 @@ import Language.GraphQL.Type.Schema
data Replacement = Replacement
{ fragments :: HashMap Core.Name Core.Fragment
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, variableValues :: Schema.Subs
}
type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
liftJust :: forall a. a -> TransformT a
liftJust = lift . lift . Just
type TransformT a = State Replacement a
-- | GraphQL document is a non-empty list of operations.
data Document = Document
Core.Operation
(HashMap Full.Name Full.FragmentDefinition)
newtype Document = Document Core.Operation
data OperationDefinition = OperationDefinition
Full.OperationType
@ -120,18 +117,44 @@ coerceVariableValues :: (Monad m, VariableValue a)
-> OperationDefinition
-> HashMap.HashMap Full.Name a
-> Either QueryError Schema.Subs
coerceVariableValues schema (OperationDefinition _ _ variables _ _) values =
coerceVariableValues schema operationDefinition variableValues' =
let referencedTypes = collectReferencedTypes schema
OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
coerceValue' = coerceValue referencedTypes
in maybe (Left CoercionError) Right
$ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables
$ foldr coerceValue' (Just HashMap.empty) variableDefinitions
where
coerceValue referencedTypes variableDefinition coercedValues = do
let Full.VariableDefinition variableName variableTypeName _defaultValue =
let Full.VariableDefinition variableName variableTypeName defaultValue =
variableDefinition
let defaultValue' = constValue <$> defaultValue
let value' = HashMap.lookup variableName variableValues'
variableType <- lookupInputType variableTypeName referencedTypes
value' <- HashMap.lookup variableName values
coercedValue <- coerceVariableValue variableType value'
HashMap.insert variableName coercedValue <$> coercedValues
HashMap.insert variableName
<$> choose value' defaultValue' variableType
<*> coercedValues
choose Nothing defaultValue variableType
| Just _ <- defaultValue = defaultValue
| not (isNonNullInputType variableType) = Just Core.Null
choose (Just value') _ variableType
| Just coercedValue <- coerceVariableValue variableType value'
, not (isNonNullInputType variableType) || coercedValue /= Core.Null =
Just coercedValue
choose _ _ _ = Nothing
constValue :: Full.ConstValue -> Core.Value
constValue (Full.ConstInt i) = Core.Int i
constValue (Full.ConstFloat f) = Core.Float f
constValue (Full.ConstString x) = Core.String x
constValue (Full.ConstBoolean b) = Core.Boolean b
constValue Full.ConstNull = Core.Null
constValue (Full.ConstEnum e) = Core.Enum e
constValue (Full.ConstList l) = Core.List $ constValue <$> l
constValue (Full.ConstObject o) =
Core.Object $ HashMap.fromList $ constObjectField <$> o
where
constObjectField (Full.ObjectField key value') = (key, constValue value')
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
@ -148,10 +171,8 @@ document schema operationName subs ast = do
chosenOperation <- getOperation operationName nonEmptyOperations
coercedValues <- coerceVariableValues schema chosenOperation subs
maybe (Left TransformationError) Right
$ Document
<$> operation fragmentTable coercedValues chosenOperation
<*> pure fragmentTable
pure $ Document
$ operation fragmentTable coercedValues chosenOperation
where
defragment definition (operations, fragments')
| (Full.ExecutableDefinition executable) <- definition
@ -174,10 +195,11 @@ operation
:: HashMap Full.Name Full.FragmentDefinition
-> Schema.Subs
-> OperationDefinition
-> Maybe Core.Operation
operation fragmentTable subs operationDefinition = flip runReaderT subs
-> Core.Operation
operation fragmentTable subs operationDefinition
= runIdentity
$ evalStateT (collectFragments >> transform operationDefinition)
$ Replacement HashMap.empty fragmentTable
$ Replacement HashMap.empty fragmentTable subs
where
transform :: OperationDefinition -> TransformT Core.Operation
transform (OperationDefinition Full.Query name _ _ sels) =
@ -201,13 +223,15 @@ selection (Full.FragmentSpread name directives') =
maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
spreadDirectives <- Directive.selection <$> directives directives'
fragments' <- gets fragments
fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
pure $ fragment <$ spreadDirectives
where
lookupDefinition = do
fragmentDefinitions' <- gets fragmentDefinitions
found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
fragmentDefinition found
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
lift $ pure $ fragment <$ spreadDirectives
Nothing -> lift $ pure Nothing
selection (Full.InlineFragment type' directives' selections) = do
fragmentDirectives <- Directive.selection <$> directives directives'
case fragmentDirectives of
@ -255,13 +279,13 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
fragmentSelection <- appendSelection selections
let newValue = Core.Fragment type' fragmentSelection
modify $ insertFragment newValue
liftJust newValue
lift $ pure newValue
where
deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
Replacement fragments' $ HashMap.delete name fragmentDefinitions'
insertFragment newValue (Replacement fragments' fragmentDefinitions') =
deleteFragmentDefinition (Replacement fragments' fragmentDefinitions' subs) =
Replacement fragments' (HashMap.delete name fragmentDefinitions') subs
insertFragment newValue (Replacement fragments' fragmentDefinitions' subs) =
let newFragments = HashMap.insert name newValue fragments'
in Replacement newFragments fragmentDefinitions'
in Replacement newFragments fragmentDefinitions' subs
arguments :: [Full.Argument] -> TransformT Core.Arguments
arguments = fmap Core.Arguments . foldM go HashMap.empty
@ -271,7 +295,8 @@ arguments = fmap Core.Arguments . foldM go HashMap.empty
return $ HashMap.insert name substitutedValue arguments'
value :: Full.Value -> TransformT Core.Value
value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
value (Full.Variable name) =
gets $ fromMaybe Core.Null . HashMap.lookup name . variableValues
value (Full.Int i) = pure $ Core.Int i
value (Full.Float f) = pure $ Core.Float f
value (Full.String x) = pure $ Core.String x

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

@ -8,9 +8,7 @@ module Language.GraphQL.Schema
, object
, resolve
, resolversToMap
, scalar
, wrappedObject
, wrappedScalar
-- * AST Reexports
, Field
, Value(..)
@ -50,31 +48,18 @@ resolversToMap = HashMap.fromList . toList . fmap toKV
-- and the value is the variable value.
type Subs = HashMap Name Value
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
object name = Resolver name
. Definition.NestingResolver
. fmap (Type.Named . resolversToMap)
-- | Like 'object' but can be null or a list of objects.
wrappedObject :: Monad m
=> Name
-> ActionT m (Type.Wrapping [Resolver m])
-> ActionT m (Type.Wrapping (Definition.FieldResolver m))
-> Resolver m
wrappedObject name = Resolver name
. Definition.NestingResolver
. (fmap . fmap) resolversToMap
wrappedObject name = Resolver name . Definition.NestingResolver
-- | A scalar represents a primitive value, like a string or an integer.
scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
scalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
-- | Like 'scalar' but can be null or a list of scalars.
wrappedScalar :: (Monad m, Aeson.ToJSON a)
=> Name
-> ActionT m (Type.Wrapping a)
-> Resolver m
wrappedScalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: Monad m
=> [Resolver m]
-> Type.Wrapping (Definition.FieldResolver m)
object = Type.O . resolversToMap
resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
resolveFieldValue field@(Field _ _ args _) =
@ -82,11 +67,6 @@ resolveFieldValue field@(Field _ _ args _) =
. runExceptT
. runActionT
convert :: Type.Wrapping Aeson.Value -> Aeson.Value
convert Type.Null = Aeson.Null
convert (Type.Named value) = value
convert (Type.List value) = Aeson.toJSON value
withField :: Monad m
=> Field
-> Definition.FieldResolver m
@ -94,14 +74,22 @@ withField :: Monad m
withField field (Definition.ValueResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver
either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
withField field@(Field _ _ _ seqSelection) (Definition.NestingResolver resolver) = do
withField field (Definition.NestingResolver resolver) = do
answer <- lift $ resolveFieldValue field resolver
case answer of
Right result -> do
nestedFields <- traverse (`resolve` seqSelection) result
pure $ HashMap.singleton (aliasOrName field) $ convert nestedFields
Right result -> HashMap.singleton (aliasOrName field) <$> toJSON field result
Left errorMessage -> errmsg field errorMessage
toJSON :: Monad m => Field -> Type.Wrapping (Definition.FieldResolver m) -> CollectErrsT m Aeson.Value
toJSON _ Type.Null = pure Aeson.Null
toJSON _ (Type.I i) = pure $ Aeson.toJSON i
toJSON _ (Type.B i) = pure $ Aeson.toJSON i
toJSON _ (Type.F i) = pure $ Aeson.toJSON i
toJSON _ (Type.E i) = pure $ Aeson.toJSON i
toJSON _ (Type.S i) = pure $ Aeson.toJSON i
toJSON field (Type.List list) = Aeson.toJSON <$> traverse (toJSON field) list
toJSON (Field _ _ _ seqSelection) (Type.O map') = map' `resolve` seqSelection
errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value)
errmsg field errorMessage = do
addErrMsg errorMessage
@ -127,6 +115,14 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
if Right (Aeson.String typeCondition) == that
then fmap fold . traverse tryResolvers $ selections'
else pure mempty
| Just (Definition.NestingResolver resolver) <- lookupResolver "__typename" = do
let fakeField = Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue fakeField resolver
case that of
Right (Type.S typeCondition')
| typeCondition' == typeCondition ->
fmap fold . traverse tryResolvers $ selections'
_ -> pure mempty
| otherwise = fmap fold . traverse tryResolvers $ selections'
aliasOrName :: Field -> Text

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

@ -3,8 +3,9 @@ module Language.GraphQL.Type
( Wrapping(..)
) where
import Data.Aeson as Aeson (ToJSON, toJSON)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Language.GraphQL.AST.Document (Name)
-- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
-- type can wrap other wrapping or named types. Wrapping types are lists and
@ -15,26 +16,38 @@ import qualified Data.Aeson as Aeson
-- nullable or an (arbitrary nested) list.
data Wrapping a
= List [Wrapping a] -- ^ Arbitrary nested list
| Named a -- ^ Named type without further wrapping
-- | Named a -- ^ Named type without further wrapping
| Null -- ^ Null
| O (HashMap Name a)
| I Int
| B Bool
| F Float
| E Text
| S Text
deriving (Eq, Show)
instance Functor Wrapping where
fmap f (List list) = List $ fmap (fmap f) list
fmap f (Named named) = Named $ f named
fmap f (O map') = O $ f <$> map'
fmap _ Null = Null
fmap _ (I i) = I i
fmap _ (B i) = B i
fmap _ (F i) = F i
fmap _ (E i) = E i
fmap _ (S i) = S i
instance Foldable Wrapping where
{-instance Foldable Wrapping where
foldr f acc (List list) = foldr (flip $ foldr f) acc list
foldr f acc (Named named) = f named acc
foldr _ acc Null = acc
foldr f acc (O map') = foldr f acc map'
foldr _ acc _ = acc -}
instance Traversable Wrapping where
{-instance Traversable Wrapping where
traverse f (List list) = List <$> traverse (traverse f) list
traverse f (Named named) = Named <$> f named
traverse _ Null = pure Null
traverse f (O map') = O <$> traverse f map'-}
instance Applicative Wrapping where
{-instance Applicative Wrapping where
pure = Named
Null <*> _ = Null
_ <*> Null = Null
@ -47,9 +60,4 @@ instance Monad Wrapping where
return = pure
Null >>= _ = Null
(Named x) >>= f = f x
(List xs) >>= f = List $ fmap (>>= f) xs
instance ToJSON a => ToJSON (Wrapping a) where
toJSON (List list) = toJSON list
toJSON (Named named) = toJSON named
toJSON Null = Aeson.Null
(List xs) >>= f = List $ fmap (>>= f) xs-}

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

@ -44,21 +44,21 @@ import Prelude hiding (id)
--
-- Almost all of the GraphQL types you define will be object types. Object
-- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType
{ name :: Text
, fields :: HashMap Name (Field m)
}
data ObjectType m = ObjectType Name (Maybe Text) (HashMap Name (Field m))
-- | Output object field definition.
data Field m = Field
(Maybe Text) (OutputType m) (HashMap Name Argument) (FieldResolver m)
(Maybe Text) -- ^ Description.
(OutputType m) -- ^ Field type.
(HashMap Name Argument) -- ^ Arguments.
(FieldResolver m) -- ^ Resolver.
-- | Resolving a field can result in a leaf value or an object, which is
-- represented as a list of nested resolvers, used to resolve the fields of that
-- object.
data FieldResolver m
= ValueResolver (ActionT m Aeson.Value)
| NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
| NestingResolver (ActionT m (Type.Wrapping (FieldResolver m)))
-- | Field argument definition.
data Argument = Argument (Maybe Text) InputType (Maybe Value)

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

@ -62,7 +62,7 @@ collectReferencedTypes schema =
let (EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumTypeDefinition enumType)
traverseObjectType objectType foundTypes =
let (ObjectType typeName objectFields) = objectType
let (ObjectType typeName _ objectFields) = objectType
element = ObjectTypeDefinition objectType
traverser = flip (foldr visitFields) objectFields
in collect traverser typeName element foundTypes

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

@ -5,21 +5,23 @@ module Language.GraphQL.SchemaSpec
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 Data.Text (Text)
import Language.GraphQL.AST.Core
import Language.GraphQL.Error
import Language.GraphQL.Schema
import qualified Language.GraphQL.Type as Type
import Language.GraphQL.Type.Definition
import Test.Hspec (Spec, describe, it, shouldBe)
spec :: Spec
spec =
describe "resolve" $
it "ignores invalid __typename" $ do
let resolver = object "__typename" $ pure
[ scalar "field" $ pure ("T" :: Text)
let resolver = NestingResolver $ pure $ object
[ wrappedObject "field" $ pure $ Type.S "T"
]
schema = resolversToMap [resolver]
schema = HashMap.singleton "__typename" resolver
fields = Sequence.singleton
$ SelectionFragment
$ Fragment "T" Sequence.empty

2
tests/Test/DirectiveSpec.hs
View File

@ -16,7 +16,7 @@ experimentalResolver :: Schema IO
experimentalResolver = Schema { query = queryType, mutation = Nothing }
where
resolver = ValueResolver $ pure $ Number 5
queryType = ObjectType "Query"
queryType = ObjectType "Query" Nothing
$ HashMap.singleton "experimentalField"
$ Field Nothing (ScalarOutputType int) mempty resolver

27
tests/Test/FragmentSpec.hs
View File

@ -9,12 +9,12 @@ import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type as Type
import Test.Hspec
( Spec
, describe
, it
, shouldBe
, shouldSatisfy
, shouldNotSatisfy
)
import Language.GraphQL.Type.Definition
@ -22,15 +22,16 @@ import Language.GraphQL.Type.Schema
import Text.RawString.QQ (r)
size :: Schema.Resolver IO
size = Schema.scalar "size" $ return ("L" :: Text)
size = Schema.wrappedObject "size" $ pure $ Type.S "L"
circumference :: Schema.Resolver IO
circumference = Schema.scalar "circumference" $ return (60 :: Int)
circumference = Schema.wrappedObject "circumference" $ pure $ Type.I 60
garment :: Text -> Schema.Resolver IO
garment typeName = Schema.object "garment" $ return
garment typeName = Schema.wrappedObject "garment"
$ pure $ Schema.object
[ if typeName == "Hat" then circumference else size
, Schema.scalar "__typename" $ return typeName
, Schema.wrappedObject "__typename" $ pure $ Type.S typeName
]
inlineQuery :: Text
@ -50,14 +51,14 @@ hasErrors (Object object') = HashMap.member "errors" object'
hasErrors _ = True
shirtType :: ObjectType IO
shirtType = ObjectType "Shirt"
shirtType = ObjectType "Shirt" Nothing
$ HashMap.singleton resolverName
$ Field Nothing (ScalarOutputType string) mempty resolve
where
(Schema.Resolver resolverName resolve) = size
hatType :: ObjectType IO
hatType = ObjectType "Hat"
hatType = ObjectType "Hat" Nothing
$ HashMap.singleton resolverName
$ Field Nothing (ScalarOutputType int) mempty resolve
where
@ -68,7 +69,7 @@ toSchema (Schema.Resolver resolverName resolve) = Schema
{ query = queryType, mutation = Nothing }
where
unionMember = if resolverName == "Hat" then hatType else shirtType
queryType = ObjectType "Query"
queryType = ObjectType "Query" Nothing
$ HashMap.singleton resolverName
$ Field Nothing (ObjectOutputType unionMember) mempty resolve
@ -106,7 +107,8 @@ spec = do
}
}
}|]
resolvers = Schema.object "garment" $ return [circumference, size]
resolvers = Schema.wrappedObject "garment"
$ pure $ Schema.object [circumference, size]
actual <- graphql (toSchema resolvers) sourceQuery
let expected = object
@ -177,7 +179,10 @@ spec = do
in actual `shouldBe` expected
it "rejects recursive fragments" $ do
let sourceQuery = [r|
let expected = object
[ "data" .= object []
]
sourceQuery = [r|
{
...circumferenceFragment
}
@ -188,7 +193,7 @@ spec = do
|]
actual <- graphql (toSchema circumference) sourceQuery
actual `shouldSatisfy` hasErrors
actual `shouldBe` expected
it "considers type condition" $ do
let sourceQuery = [r|

28
tests/Test/RootOperationSpec.hs
View File

@ -6,38 +6,36 @@ module Test.RootOperationSpec
import Data.Aeson ((.=), object)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
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
import Language.GraphQL.Type.Schema
import qualified Language.GraphQL.Type as Type
hatType :: ObjectType IO
hatType = ObjectType "Hat"
hatType = ObjectType "Hat" Nothing
$ HashMap.singleton resolverName
$ Field Nothing (ScalarOutputType int) mempty resolve
where
(Schema.Resolver resolverName resolve) =
Schema.scalar "circumference" $ pure (60 :: Int)
Schema.wrappedObject "circumference" $ pure $ Type.I 60
schema :: Schema IO
schema = Schema
(ObjectType "Query" hatField)
(Just $ ObjectType "Mutation" incrementField)
(ObjectType "Query" Nothing hatField)
(Just $ ObjectType "Mutation" Nothing incrementField)
where
queryResolvers = Schema.resolversToMap $ garment :| []
mutationResolvers = Schema.resolversToMap $ increment :| []
garment = Schema.object "garment" $ pure
[ Schema.scalar "circumference" $ pure (60 :: Int)
garment = NestingResolver
$ pure $ Schema.object
[ Schema.wrappedObject "circumference" $ pure $ Type.I 60
]
increment = Schema.scalar "incrementCircumference"
$ pure (61 :: Int)
incrementField = Field Nothing (ScalarOutputType int) mempty
<$> mutationResolvers
hatField = Field Nothing (ObjectOutputType hatType) mempty
<$> queryResolvers
incrementField = HashMap.singleton "incrementCircumference"
$ Field Nothing (ScalarOutputType int) mempty
$ NestingResolver $ pure $ Type.I 61
hatField = HashMap.singleton "garment"
$ Field Nothing (ObjectOutputType hatType) mempty garment
spec :: Spec
spec =

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

@ -22,7 +22,6 @@ import Control.Monad.Trans.Except (throwE)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type as Type
-- * Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@ -184,8 +183,8 @@ getDroid' _ = empty
getFriends :: Character -> [Character]
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
getEpisode :: Int -> Maybe (Type.Wrapping Text)
getEpisode 4 = pure $ Type.Named "NEWHOPE"
getEpisode 5 = pure $ Type.Named "EMPIRE"
getEpisode 6 = pure $ Type.Named "JEDI"
getEpisode :: Int -> Maybe Text
getEpisode 4 = pure $ "NEWHOPE"
getEpisode 5 = pure $ "EMPIRE"
getEpisode 6 = pure $ "JEDI"
getEpisode _ = empty

2
tests/Test/StarWars/QuerySpec.hs
View File

@ -39,7 +39,7 @@ spec = describe "Star Wars Query Tests" $ do
id
name
friends {
name
name
}
}
}

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

@ -10,7 +10,7 @@ module Test.StarWars.Schema
import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Class (lift)
import Data.Functor.Identity (Identity)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Trans
@ -24,46 +24,51 @@ import Test.StarWars.Data
schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing }
where
queryType = ObjectType "Query"
$ Field Nothing (ScalarOutputType string) mempty
<$> Schema.resolversToMap (hero :| [human, droid])
queryType = ObjectType "Query" Nothing $ HashMap.fromList
[ ("hero", Field Nothing (ScalarOutputType string) mempty hero)
, ("human", Field Nothing (ScalarOutputType string) mempty human)
, ("droid", Field Nothing (ScalarOutputType string) mempty droid)
]
hero :: Schema.Resolver Identity
hero = Schema.object "hero" $ do
hero :: FieldResolver Identity
hero = NestingResolver $ do
episode <- argument "episode"
character $ case episode of
pure $ character $ case episode of
Schema.Enum "NEWHOPE" -> getHero 4
Schema.Enum "EMPIRE" -> getHero 5
Schema.Enum "JEDI" -> getHero 6
_ -> artoo
human :: Schema.Resolver Identity
human = Schema.wrappedObject "human" $ do
human :: FieldResolver Identity
human = NestingResolver $ do
id' <- argument "id"
case id' of
Schema.String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of
Nothing -> return Type.Null
Just e -> Type.Named <$> character e
Nothing -> pure Type.Null
Just e -> pure $ character e
_ -> ActionT $ throwE "Invalid arguments."
droid :: Schema.Resolver Identity
droid = Schema.object "droid" $ do
droid :: FieldResolver Identity
droid = NestingResolver $ do
id' <- argument "id"
case id' of
Schema.String i -> character =<< getDroid i
Schema.String i -> getDroid i >>= pure . character
_ -> ActionT $ throwE "Invalid arguments."
character :: Character -> ActionT Identity [Schema.Resolver Identity]
character char = return
[ Schema.scalar "id" $ return $ id_ char
, Schema.scalar "name" $ return $ name_ char
character :: Character -> Type.Wrapping (FieldResolver Identity)
character char = Schema.object
[ Schema.wrappedObject "id" $ pure $ Type.S $ id_ char
, Schema.wrappedObject "name" $ pure $ Type.S $ name_ char
, Schema.wrappedObject "friends"
$ traverse character $ Type.List $ Type.Named <$> getFriends char
, Schema.wrappedScalar "appearsIn" $ return . Type.List
$ catMaybes (getEpisode <$> appearsIn char)
, Schema.scalar "secretBackstory" $ secretBackstory char
, Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
, Schema.scalar "__typename" $ return $ typeName char
$ pure
$ Type.List
$ fmap character
$ getFriends char
, Schema.wrappedObject "appearsIn" $ pure
$ Type.List $ Type.E <$> catMaybes (getEpisode <$> appearsIn char)
, Schema.wrappedObject "secretBackstory" $ Type.S <$> secretBackstory char
, Schema.wrappedObject "homePlanet" $ pure $ Type.S $ either mempty homePlanet char
, Schema.wrappedObject "__typename" $ pure $ Type.S $ typeName char
]