From 7cd48217187911855cd2ad473e58d11df0c69d48 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 23 May 2020 06:46:21 +0200 Subject: [PATCH] Don't fail on invalid fragments and variables --- CHANGELOG.md | 12 ++- docs/tutorial/tutorial.lhs | 34 +++++---- package.yaml | 1 + src/Language/GraphQL/Execute.hs | 5 +- src/Language/GraphQL/Execute/Coerce.hs | 2 + src/Language/GraphQL/Execute/Transform.hs | 93 ++++++++++++++--------- src/Language/GraphQL/Schema.hs | 58 +++++++------- src/Language/GraphQL/Type.hs | 38 +++++---- src/Language/GraphQL/Type/Definition.hs | 12 +-- src/Language/GraphQL/Type/Schema.hs | 2 +- tests/Language/GraphQL/SchemaSpec.hs | 10 ++- tests/Test/DirectiveSpec.hs | 2 +- tests/Test/FragmentSpec.hs | 27 ++++--- tests/Test/RootOperationSpec.hs | 28 ++++--- tests/Test/StarWars/Data.hs | 9 +-- tests/Test/StarWars/QuerySpec.hs | 2 +- tests/Test/StarWars/Schema.hs | 53 +++++++------ 17 files changed, 219 insertions(+), 169 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c54d090..66a3c5d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index 9b04ea3..c70c64c 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -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 }" diff --git a/package.yaml b/package.yaml index a61aca3..d50aac5 100644 --- a/package.yaml +++ b/package.yaml @@ -35,6 +35,7 @@ dependencies: - text - transformers - unordered-containers +- vector library: source-dirs: src diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 7513b6e..295cb44 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -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') = diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index ead19dc..6997945 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 485bd51..df64254 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -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 diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 752ce29..69f697e 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -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 diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index c8a9997..12b38dc 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -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-} diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index a916d51..559611b 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -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) diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index fa44694..095f27d 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -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 diff --git a/tests/Language/GraphQL/SchemaSpec.hs b/tests/Language/GraphQL/SchemaSpec.hs index 6804150..a5d37c0 100644 --- a/tests/Language/GraphQL/SchemaSpec.hs +++ b/tests/Language/GraphQL/SchemaSpec.hs @@ -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 diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 56bbb12..74167c9 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 671def5..1616865 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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| diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 08955f3..935b96d 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -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 = diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index 3cc8945..30a4cef 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -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 diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs index e9147ff..39d6a27 100644 --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -39,7 +39,7 @@ spec = describe "Star Wars Query Tests" $ do id name friends { - name + name } } } diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 253c6ca..5e702e0 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -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 ]