diff --git a/CHANGELOG.md b/CHANGELOG.md index dc93324..a0268bd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,6 +18,7 @@ and this project adheres to - Argument value coercion. - Variable value coercion. - The executor should skip the fields missing in the object type and not fail. +- Merging subselections. ### Changed - `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index a7b57f8..647c60f 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -10,6 +10,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.State (gets) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Map.Strict (Map) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -17,7 +18,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Sequence (Seq(..)) import Data.Text (Text) -import qualified Data.Sequence as Seq import Language.GraphQL.AST (Name) import Language.GraphQL.AST.Core import Language.GraphQL.Error @@ -42,12 +42,12 @@ resolveFieldValue result args = collectFields :: Monad m => Out.ObjectType m -> Seq (Selection m) - -> Map Name (Seq (Field m)) + -> Map Name (NonEmpty (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 + in Map.insertWith (<>) responseKey (field :| []) groupedFields forEach groupedFields (SelectionFragment selectionFragment) | Fragment fragmentType fragmentSelectionSet <- selectionFragment , doesFragmentTypeApply fragmentType objectType = @@ -98,24 +98,24 @@ instanceOf objectType (AbstractUnionType unionType) = go unionMemberType acc = acc || objectType == unionMemberType executeField :: Monad m - => Definition.Value - -> Field m - -> Out.Resolver m + => Out.Resolver m + -> Definition.Value + -> NonEmpty (Field m) -> CollectErrsT m Aeson.Value -executeField prev field (Out.Resolver fieldDefinition resolver) = do +executeField (Out.Resolver fieldDefinition resolver) prev fields = do let Out.Field _ fieldType argumentDefinitions = fieldDefinition - let Field _ _ arguments' _ = field + let (Field _ _ arguments' _ :| []) = fields case coerceArgumentValues argumentDefinitions arguments' of Nothing -> errmsg "Argument coercing failed." Just argumentValues -> do answer <- lift $ resolveFieldValue prev argumentValues resolver case answer of - Right result -> completeValue fieldType field result + Right result -> completeValue fieldType fields result Left errorMessage -> errmsg errorMessage completeValue :: Monad m => Out.Type m - -> Field m + -> NonEmpty (Field m) -> Definition.Value -> CollectErrsT m Aeson.Value completeValue _ _ Definition.Null = pure Aeson.Null @@ -124,24 +124,32 @@ completeValue _ _ (Definition.Boolean boolean') = pure $ Aeson.Bool boolean' completeValue _ _ (Definition.Float float') = pure $ Aeson.toJSON float' completeValue _ _ (Definition.Enum enum) = pure $ Aeson.String enum completeValue _ _ (Definition.String string') = pure $ Aeson.String string' -completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result = - executeSelectionSet result objectType seqSelection -completeValue (Out.ListBaseType listType) selectionField (Definition.List list) = - Aeson.toJSON <$> traverse (completeValue listType selectionField) list -completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result +completeValue (Out.ListBaseType listType) fields (Definition.List list) = + Aeson.toJSON <$> traverse (completeValue listType fields) list +completeValue (Out.ObjectBaseType objectType) fields result = + executeSelectionSet result objectType $ mergeSelectionSets fields +completeValue (Out.InterfaceBaseType interfaceType) fields result | Definition.Object objectMap <- result = do abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap case abstractType of - Just objectType -> executeSelectionSet result objectType seqSelection + Just objectType -> executeSelectionSet result objectType + $ mergeSelectionSets fields Nothing -> errmsg "Value completion failed." -completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result +completeValue (Out.UnionBaseType unionType) fields result | Definition.Object objectMap <- result = do abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap case abstractType of - Just objectType -> executeSelectionSet result objectType seqSelection + Just objectType -> executeSelectionSet result objectType + $ mergeSelectionSets fields Nothing -> errmsg "Value completion failed." completeValue _ _ _ = errmsg "Value completion failed." +mergeSelectionSets :: Monad m => NonEmpty (Field m) -> Seq (Selection m) +mergeSelectionSets fields = foldr forEach mempty fields + where + forEach (Field _ _ _ fieldSelectionSet) selectionSet = + selectionSet <> fieldSelectionSet + errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null @@ -154,17 +162,16 @@ executeSelectionSet :: Monad m -> Seq (Selection m) -> CollectErrsT m Aeson.Value executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do - resolvedValues <- Map.traverseMaybeWithKey forEach - $ collectFields objectType selectionSet + let fields = collectFields objectType selectionSet + resolvedValues <- Map.traverseMaybeWithKey forEach fields pure $ Aeson.toJSON resolvedValues where - forEach _responseKey (field :<| _) = + forEach _ fields@(field :| _) = let Field _ name _ _ = field - in traverse (tryResolver field) $ lookupResolver name - forEach _ _ = pure Nothing + in traverse (tryResolver fields) $ lookupResolver name lookupResolver = flip HashMap.lookup resolvers - tryResolver typeField field = - executeField result typeField field >>= lift . pure + tryResolver fields resolver = + executeField resolver result fields >>= lift . pure coerceArgumentValues :: HashMap Name In.Argument diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index d0e7a66..62c6f25 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -22,21 +22,54 @@ schema = Schema {query = queryType, mutation = Nothing} queryType :: Out.ObjectType Identity queryType = Out.ObjectType "Query" Nothing [] - $ HashMap.singleton "count" - $ Out.Resolver countField + $ HashMap.singleton "philosopher" + $ Out.Resolver philosopherField $ pure - $ Int 8 + $ Object mempty where - countField = Out.Field Nothing (Out.NonNullScalarType int) HashMap.empty + philosopherField = + Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty + +philosopherType :: Out.ObjectType Identity +philosopherType = Out.ObjectType "Philosopher" Nothing [] + $ HashMap.fromList resolvers + where + resolvers = + [ ("firstName", firstNameResolver) + , ("lastName", lastNameResolver) + ] + firstNameResolver = Out.Resolver firstNameField $ pure $ String "Friedrich" + lastNameResolver = Out.Resolver lastNameField $ pure $ String "Nietzsche" + firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty spec :: Spec spec = - describe "execute" $ + describe "execute" $ do it "skips unknown fields" $ let expected = Aeson.object - ["data" .= Aeson.object ["count" .= (8 :: Int)]] + [ "data" .= Aeson.object + [ "philosopher" .= Aeson.object + [ "firstName" .= ("Friedrich" :: String) + ] + ] + ] execute' = execute schema (mempty :: HashMap Name Aeson.Value) actual = runIdentity $ either parseError execute' - $ parse document "" "{ count number }" + $ parse document "" "{ philosopher { firstName surname } }" + in actual `shouldBe` expected + it "merges selections" $ + let expected = Aeson.object + [ "data" .= Aeson.object + [ "philosopher" .= Aeson.object + [ "firstName" .= ("Friedrich" :: String) + , "lastName" .= ("Nietzsche" :: String) + ] + ] + ] + execute' = execute schema (mempty :: HashMap Name Aeson.Value) + actual = runIdentity + $ either parseError execute' + $ parse document "" "{ philosopher { firstName } philosopher { lastName } }" in actual `shouldBe` expected