summaryrefslogtreecommitdiff
path: root/src/Language/GraphQL/Execute/Execution.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL/Execute/Execution.hs')
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs253
1 files changed, 0 insertions, 253 deletions
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
deleted file mode 100644
index 9ad4439..0000000
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ /dev/null
@@ -1,253 +0,0 @@
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module Language.GraphQL.Execute.Execution
- ( coerceArgumentValues
- , collectFields
- , executeSelectionSet
- ) where
-
-import Control.Monad.Catch (Exception(..), MonadCatch(..))
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Reader (runReaderT)
-import Control.Monad.Trans.State (gets)
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (fromMaybe)
-import Data.Sequence (Seq(..))
-import qualified Data.Text as Text
-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
-import qualified Language.GraphQL.Type.Out as Out
-import qualified Language.GraphQL.Type.Internal as Internal
-import Prelude hiding (null)
-
-resolveFieldValue :: MonadCatch m
- => Type.Value
- -> Type.Subs
- -> Type.Resolve m
- -> Full.Location
- -> CollectErrsT m Type.Value
-resolveFieldValue result args resolver location' =
- catch (lift $ runReaderT resolver context) handleFieldError
- where
- handleFieldError :: MonadCatch m
- => ResolverException
- -> CollectErrsT m Type.Value
- handleFieldError e
- = addError Type.Null
- $ Error (Text.pack $ displayException e) [location'] []
- context = Type.Context
- { Type.arguments = Type.Arguments args
- , Type.values = result
- }
-
-collectFields :: Monad m
- => Out.ObjectType m
- -> Seq (Transform.Selection m)
- -> OrderedMap (NonEmpty (Transform.Field m))
-collectFields objectType = foldl forEach OrderedMap.empty
- where
- forEach groupedFields (Transform.SelectionField field) =
- let responseKey = aliasOrName field
- 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 groupedFields <> fragmentGroupedFieldSet
- | otherwise = groupedFields
-
-aliasOrName :: forall m. Transform.Field m -> Full.Name
-aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias
-
-resolveAbstractType :: Monad m
- => Internal.AbstractType m
- -> Type.Subs
- -> CollectErrsT m (Maybe (Out.ObjectType m))
-resolveAbstractType abstractType values'
- | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
- types' <- gets types
- case HashMap.lookup typeName types' of
- Just (Internal.ObjectType objectType) ->
- if Internal.instanceOf objectType abstractType
- then pure $ Just objectType
- else pure Nothing
- _ -> pure Nothing
- | otherwise = pure Nothing
-
-executeField :: (MonadCatch m, Serialize a)
- => Out.Resolver m
- -> Type.Value
- -> NonEmpty (Transform.Field m)
- -> CollectErrsT m a
-executeField fieldResolver prev fields
- | Out.ValueResolver fieldDefinition resolver <- fieldResolver =
- executeField' fieldDefinition resolver
- | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver =
- executeField' fieldDefinition resolver
- where
- executeField' fieldDefinition resolver = do
- let Out.Field _ fieldType argumentDefinitions = fieldDefinition
- let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields
- case coerceArgumentValues argumentDefinitions arguments' of
- 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)
- => Out.Type m
- -> NonEmpty (Transform.Field m)
- -> Type.Value
- -> CollectErrsT m 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 (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 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 location
- $ mergeSelectionSets fields
- 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
- 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 =
- 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 parentLocation result
- | Just serialized <- serialize outputType result = pure serialized
- | 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
--- the resolved 'Transform.Selection', or a null value and error information.
-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) objectLocation selectionSet = do
- let fields = collectFields objectType selectionSet
- resolvedValues <- OrderedMap.traverseMaybe forEach fields
- coerceResult (Out.NonNullObjectType objectType) objectLocation
- $ Object resolvedValues
- where
- 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 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 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) =
- coerceInputLiteral inputType (Type.Boolean boolean)
- coerceArgumentValue inputType (Transform.String string) =
- coerceInputLiteral inputType (Type.String string)
- coerceArgumentValue inputType (Transform.Float float) =
- coerceInputLiteral inputType (Type.Float float)
- coerceArgumentValue inputType (Transform.Enum enum) =
- coerceInputLiteral inputType (Type.Enum enum)
- coerceArgumentValue inputType Transform.Null
- | In.isNonNullType inputType = Nothing
- | otherwise = coerceInputLiteral inputType Type.Null
- coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
- let coerceItem = coerceInputLiteral inputType
- in Type.List <$> traverse coerceItem list
- coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
- | In.InputObjectType _ _ inputFields <- inputType =
- let go = forEachField object
- resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
- in Type.Object <$> resultMap
- coerceArgumentValue _ (Transform.Variable variable) = pure variable
- coerceArgumentValue _ _ = Nothing
- forEachField object variableName (In.InputField _ variableType defaultValue) =
- matchFieldValues coerceArgumentValue object variableName variableType defaultValue
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 22:12:41 +0000