diff options
Diffstat (limited to 'src/Language/GraphQL/Execute/Execution.hs')
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 135 |
1 files changed, 86 insertions, 49 deletions
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 9d588ca..9ad4439 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -13,16 +14,18 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.State (gets) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map.Strict (Map) +import qualified Data.List.NonEmpty as NonEmpty import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Sequence (Seq(..)) import qualified Data.Text as Text -import Language.GraphQL.AST (Name) +import qualified Language.GraphQL.AST as Full import Language.GraphQL.Error import Language.GraphQL.Execute.Coerce +import Language.GraphQL.Execute.Internal +import Language.GraphQL.Execute.OrderedMap (OrderedMap) +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In @@ -34,15 +37,17 @@ resolveFieldValue :: MonadCatch m => Type.Value -> Type.Subs -> Type.Resolve m + -> Full.Location -> CollectErrsT m Type.Value -resolveFieldValue result args resolver = +resolveFieldValue result args resolver location' = catch (lift $ runReaderT resolver context) handleFieldError where handleFieldError :: MonadCatch m => ResolverException -> CollectErrsT m Type.Value - handleFieldError e = - addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null + handleFieldError e + = addError Type.Null + $ Error (Text.pack $ displayException e) [location'] [] context = Type.Context { Type.arguments = Type.Arguments args , Type.values = result @@ -51,21 +56,21 @@ resolveFieldValue result args resolver = collectFields :: Monad m => Out.ObjectType m -> Seq (Transform.Selection m) - -> Map Name (NonEmpty (Transform.Field m)) -collectFields objectType = foldl forEach Map.empty + -> OrderedMap (NonEmpty (Transform.Field m)) +collectFields objectType = foldl forEach OrderedMap.empty where forEach groupedFields (Transform.SelectionField field) = let responseKey = aliasOrName field - in Map.insertWith (<>) responseKey (field :| []) groupedFields + in OrderedMap.insert responseKey (field :| []) groupedFields forEach groupedFields (Transform.SelectionFragment selectionFragment) | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment , Internal.doesFragmentTypeApply fragmentType objectType = let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet - in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet + in groupedFields <> fragmentGroupedFieldSet | otherwise = groupedFields -aliasOrName :: forall m. Transform.Field m -> Name -aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias +aliasOrName :: forall m. Transform.Field m -> Full.Name +aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias resolveAbstractType :: Monad m => Internal.AbstractType m @@ -95,11 +100,15 @@ executeField fieldResolver prev fields where executeField' fieldDefinition resolver = do let Out.Field _ fieldType argumentDefinitions = fieldDefinition - let (Transform.Field _ _ arguments' _ :| []) = fields + let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields case coerceArgumentValues argumentDefinitions arguments' of - Nothing -> addErrMsg "Argument coercing failed." - Just argumentValues -> do - answer <- resolveFieldValue prev argumentValues resolver + Left [] -> + let errorMessage = "Not all required arguments are specified." + in addError null $ Error errorMessage [location'] [] + Left errorLocations -> addError null + $ Error "Argument coercing failed." errorLocations [] + Right argumentValues -> do + answer <- resolveFieldValue prev argumentValues resolver location' completeValue fieldType fields answer completeValue :: (MonadCatch m, Serialize a) @@ -110,55 +119,67 @@ completeValue :: (MonadCatch m, Serialize a) completeValue (Out.isNonNullType -> False) _ Type.Null = pure null completeValue outputType@(Out.ListBaseType listType) fields (Type.List list) = traverse (completeValue listType fields) list - >>= coerceResult outputType . List -completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) = - coerceResult outputType $ Int int -completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) = - coerceResult outputType $ Boolean boolean -completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) = - coerceResult outputType $ Float float -completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) = - coerceResult outputType $ String string -completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) = + >>= coerceResult outputType (firstFieldLocation fields) . List +completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) = + coerceResult outputType (firstFieldLocation fields) $ Int int +completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) = + coerceResult outputType (firstFieldLocation fields) $ Boolean boolean +completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) = + coerceResult outputType (firstFieldLocation fields) $ Float float +completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) = + coerceResult outputType (firstFieldLocation fields) $ String string +completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) = let Type.EnumType _ _ enumMembers = enumType + location = firstFieldLocation fields in if HashMap.member enum enumMembers - then coerceResult outputType $ Enum enum - else addErrMsg "Enum value completion failed." -completeValue (Out.ObjectBaseType objectType) fields result = - executeSelectionSet result objectType $ mergeSelectionSets fields + then coerceResult outputType location $ Enum enum + else addError null $ Error "Enum value completion failed." [location] [] +completeValue (Out.ObjectBaseType objectType) fields result + = executeSelectionSet result objectType (firstFieldLocation fields) + $ mergeSelectionSets fields completeValue (Out.InterfaceBaseType interfaceType) fields result | Type.Object objectMap <- result = do let abstractType = Internal.AbstractInterfaceType interfaceType + let location = firstFieldLocation fields concreteType <- resolveAbstractType abstractType objectMap case concreteType of - Just objectType -> executeSelectionSet result objectType + Just objectType -> executeSelectionSet result objectType location $ mergeSelectionSets fields - Nothing -> addErrMsg "Interface value completion failed." + Nothing -> addError null + $ Error "Interface value completion failed." [location] [] completeValue (Out.UnionBaseType unionType) fields result | Type.Object objectMap <- result = do let abstractType = Internal.AbstractUnionType unionType + let location = firstFieldLocation fields concreteType <- resolveAbstractType abstractType objectMap case concreteType of Just objectType -> executeSelectionSet result objectType - $ mergeSelectionSets fields - Nothing -> addErrMsg "Union value completion failed." -completeValue _ _ _ = addErrMsg "Value completion failed." + location $ mergeSelectionSets fields + Nothing -> addError null + $ Error "Union value completion failed." [location] [] +completeValue _ (Transform.Field _ _ _ _ location :| _) _ = + addError null $ Error "Value completion failed." [location] [] mergeSelectionSets :: MonadCatch m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m) mergeSelectionSets = foldr forEach mempty where - forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet = + forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet = selectionSet <> fieldSelectionSet +firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location +firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation + coerceResult :: (MonadCatch m, Serialize a) => Out.Type m + -> Full.Location -> Output a -> CollectErrsT m a -coerceResult outputType result +coerceResult outputType parentLocation result | Just serialized <- serialize outputType result = pure serialized - | otherwise = addErrMsg "Result coercion failed." + | otherwise = addError null + $ Error "Result coercion failed." [parentLocation] [] -- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies -- each field to each 'Transform.Selection'. Resolves into a value containing @@ -166,29 +187,45 @@ coerceResult outputType result executeSelectionSet :: (MonadCatch m, Serialize a) => Type.Value -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) -> CollectErrsT m a -executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do +executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do let fields = collectFields objectType selectionSet - resolvedValues <- Map.traverseMaybeWithKey forEach fields - coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues + resolvedValues <- OrderedMap.traverseMaybe forEach fields + coerceResult (Out.NonNullObjectType objectType) objectLocation + $ Object resolvedValues where - forEach _ fields@(field :| _) = - let Transform.Field _ name _ _ = field + forEach fields@(field :| _) = + let Transform.Field _ name _ _ _ = field in traverse (tryResolver fields) $ lookupResolver name lookupResolver = flip HashMap.lookup resolvers tryResolver fields resolver = executeField resolver result fields >>= lift . pure coerceArgumentValues - :: HashMap Name In.Argument - -> HashMap Name Transform.Input - -> Maybe Type.Subs -coerceArgumentValues argumentDefinitions argumentValues = + :: HashMap Full.Name In.Argument + -> HashMap Full.Name (Full.Node Transform.Input) + -> Either [Full.Location] Type.Subs +coerceArgumentValues argumentDefinitions argumentNodes = HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions where - forEach variableName (In.Argument _ variableType defaultValue) = - matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue + forEach argumentName (In.Argument _ variableType defaultValue) = \case + Right resultMap + | Just matchedValues + <- matchFieldValues' argumentName variableType defaultValue $ Just resultMap + -> Right matchedValues + | otherwise -> Left $ generateError argumentName [] + Left errorLocations + | Just _ + <- matchFieldValues' argumentName variableType defaultValue $ pure mempty + -> Left errorLocations + | otherwise -> Left $ generateError argumentName errorLocations + generateError argumentName errorLocations = + case HashMap.lookup argumentName argumentNodes of + Just (Full.Node _ errorLocation) -> [errorLocation] + Nothing -> errorLocations + matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes) coerceArgumentValue inputType (Transform.Int integer) = coerceInputLiteral inputType (Type.Int integer) coerceArgumentValue inputType (Transform.Boolean boolean) = |