From d12577ae717512979c7654191ca65f25fc877907 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 27 May 2020 23:18:35 +0200 Subject: [PATCH] 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. --- CHANGELOG.md | 33 ++- docs/tutorial/tutorial.lhs | 8 +- package.yaml | 1 + src/Language/GraphQL/AST/Core.hs | 44 +--- src/Language/GraphQL/Error.hs | 50 ++--- src/Language/GraphQL/Execute.hs | 32 ++- src/Language/GraphQL/Execute/Coerce.hs | 61 +++--- src/Language/GraphQL/Execute/Execution.hs | 58 +++++ src/Language/GraphQL/Execute/Transform.hs | 216 +++++++++++-------- src/Language/GraphQL/Schema.hs | 133 ++++++------ src/Language/GraphQL/Trans.hs | 14 +- src/Language/GraphQL/Type/Definition.hs | 24 +++ src/Language/GraphQL/Type/Directive.hs | 13 +- src/Language/GraphQL/Type/In.hs | 22 +- src/Language/GraphQL/Type/Out.hs | 56 +---- src/Language/GraphQL/Type/Schema.hs | 11 +- stack.yaml | 2 +- tests/Language/GraphQL/Execute/CoerceSpec.hs | 37 ++-- tests/Language/GraphQL/SchemaSpec.hs | 32 --- tests/Language/GraphQL/Type/OutSpec.hs | 7 +- tests/Test/DirectiveSpec.hs | 7 +- tests/Test/FragmentSpec.hs | 84 ++++---- tests/Test/RootOperationSpec.hs | 15 +- tests/Test/StarWars/Data.hs | 4 +- tests/Test/StarWars/Schema.hs | 86 +++++--- 25 files changed, 534 insertions(+), 516 deletions(-) create mode 100644 src/Language/GraphQL/Execute/Execution.hs delete mode 100644 tests/Language/GraphQL/SchemaSpec.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 6846a5a..21e6477 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index 39e151c..9ca2db0 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -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. diff --git a/package.yaml b/package.yaml index d50aac5..e53d23d 100644 --- a/package.yaml +++ b/package.yaml @@ -40,6 +40,7 @@ dependencies: library: source-dirs: src other-modules: + - Language.GraphQL.Execute.Execution - Language.GraphQL.Execute.Transform - Language.GraphQL.Type.Directive diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index 6dcfb81..59d43eb 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -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) diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 91911b7..e41782d 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -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) + ] diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 862e360..ee009db 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 4a9218b..09375fd 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs new file mode 100644 index 0000000..117df30 --- /dev/null +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 8233c73..fe517d9 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -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' diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 34abf10..734f070 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -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'-} diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index 3c3ffa4..7dc5523 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index aecb64a..0f92857 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs index 9675df8..261bf04 100644 --- a/src/Language/GraphQL/Type/Directive.hs +++ b/src/Language/GraphQL/Type/Directive.hs @@ -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' diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index c2e8ded..c662797 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -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) diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index fe2d4f2..4808d09 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -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) diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 74ab974..b6055c5 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -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. diff --git a/stack.yaml b/stack.yaml index 377fac6..fcab7ad 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-15.13 +resolver: lts-15.14 packages: - . diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs index c44c6c4..ed8fd63 100644 --- a/tests/Language/GraphQL/Execute/CoerceSpec.hs +++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs @@ -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 diff --git a/tests/Language/GraphQL/SchemaSpec.hs b/tests/Language/GraphQL/SchemaSpec.hs deleted file mode 100644 index 9bc5530..0000000 --- a/tests/Language/GraphQL/SchemaSpec.hs +++ /dev/null @@ -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 diff --git a/tests/Language/GraphQL/Type/OutSpec.hs b/tests/Language/GraphQL/Type/OutSpec.hs index 48b7fa4..bdc2094 100644 --- a/tests/Language/GraphQL/Type/OutSpec.hs +++ b/tests/Language/GraphQL/Type/OutSpec.hs @@ -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." diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 67264c2..55a5277 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -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 [] ] diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 1f765a4..36e88b1 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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 diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 291b5f2..3b21788 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -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 diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index 67a74cd..bfbe836 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -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") diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index e58d33b..0ab10ec 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -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) ]