Coerce argument values properly

Fixes #44.
This commit is contained in:
Eugen Wissner 2020-06-06 21:22:11 +02:00
parent 93a0403288
commit 4c9264c12c
6 changed files with 251 additions and 160 deletions

View File

@ -15,6 +15,8 @@ and this project adheres to
- AST transformation should never fail. - AST transformation should never fail.
* Missing variable are assumed to be null. * Missing variable are assumed to be null.
* Invalid (recusrive or non-existing) fragments should be skipped. * Invalid (recusrive or non-existing) fragments should be skipped.
- Argument value coercion.
- Variable value coercion.
### Changed ### Changed
- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function - `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function

View File

@ -1,20 +1,22 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- | Types and functions used for input and result coercion. -- | Types and functions used for input and result coercion.
module Language.GraphQL.Execute.Coerce module Language.GraphQL.Execute.Coerce
( VariableValue(..) ( VariableValue(..)
, coerceInputLiterals , coerceInputLiteral
, matchFieldValues
) where ) where
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set
import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import qualified Data.Set as Set
import Data.Scientific (toBoundedInteger, toRealFloat) import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST.Document (Name) import Language.GraphQL.AST.Core
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
@ -67,10 +69,10 @@ instance VariableValue Aeson.Value where
then Just $ Object resultMap then Just $ Object resultMap
else Nothing else Nothing
where where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
$ Just (objectValue, HashMap.empty) $ Just (objectValue, HashMap.empty)
matchFieldValues _ _ Nothing = Nothing matchFieldValues' _ _ Nothing = Nothing
matchFieldValues fieldName inputField (Just (objectValue, resultMap)) = matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
let (In.InputField _ fieldType _) = inputField let (In.InputField _ fieldType _) = inputField
insert = flip (HashMap.insert fieldName) resultMap insert = flip (HashMap.insert fieldName) resultMap
newObjectValue = HashMap.delete fieldName objectValue newObjectValue = HashMap.delete fieldName objectValue
@ -90,60 +92,67 @@ instance VariableValue Aeson.Value where
pure $ coerced : list pure $ coerced : list
coerceVariableValue _ _ = Nothing coerceVariableValue _ _ = Nothing
-- | Coerces operation arguments according to the input coercion rules for the -- | Looks up a value by name in the given map, coerces it and inserts into the
-- corresponding types. -- result map. If the coercion fails, returns 'Nothing'. If the value isn't
coerceInputLiterals -- given, but a default value is known, inserts the default value into the
:: HashMap Name In.Type -- result map. Otherwise it fails with 'Nothing' if the Input Type is a
-> HashMap Name Value -- Non-Nullable type, or returns the unchanged, original map.
-> Maybe Subs matchFieldValues :: forall a
coerceInputLiterals variableTypes variableValues = . (In.Type -> a -> Maybe Value)
foldWithKey operator variableTypes -> HashMap Name a
-> Name
-> In.Type
-> Maybe Value
-> Maybe (HashMap Name Value)
-> Maybe (HashMap Name Value)
matchFieldValues coerce values' fieldName type' defaultValue resultMap =
case HashMap.lookup fieldName values' of
Just variableValue -> coerceRuntimeValue $ coerce type' variableValue
Nothing
| Just value <- defaultValue ->
HashMap.insert fieldName value <$> resultMap
| Nothing <- defaultValue
, In.isNonNullType type' -> Nothing
| otherwise -> resultMap
where
coerceRuntimeValue (Just Null)
| In.isNonNullType type' = Nothing
coerceRuntimeValue coercedValue =
HashMap.insert fieldName <$> coercedValue <*> resultMap
-- | Coerces operation arguments according to the input coercion rules for the
-- corresponding types.
coerceInputLiteral :: In.Type -> Value -> Maybe Value
coerceInputLiteral (In.ScalarBaseType type') 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 $ Float $ fromIntegral intValue
| (String stringValue) <- value
, (ScalarType "ID" _) <- type' = Just $ String stringValue
| (Int intValue) <- value
, (ScalarType "ID" _) <- type' = Just $ decimal intValue
where where
operator variableName variableType resultMap =
HashMap.insert variableName
<$> (lookupVariable variableName >>= coerceInputLiteral variableType)
<*> resultMap
coerceInputLiteral (In.NamedScalarType type') 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 $ 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') (Enum enumValue)
| member enumValue type' = Just $ Enum enumValue
coerceInputLiteral (In.NamedInputObjectType type') (Object _) =
let (In.InputObjectType _ _ inputFields) = type'
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 Null
| In.isNonNullType type' -> Nothing
| otherwise ->
HashMap.insert fieldName Null <$> resultMap
Just variableValue -> HashMap.insert fieldName
<$> coerceInputLiteral type' variableValue
<*> resultMap
Nothing
| Just value <- defaultValue ->
HashMap.insert fieldName value <$> resultMap
| Nothing <- defaultValue
, In.isNonNullType type' -> Nothing
| otherwise -> resultMap
lookupVariable = flip HashMap.lookup variableValues
foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty)
decimal = String decimal = String
. Text.Lazy.toStrict . Text.Lazy.toStrict
. Text.Builder.toLazyText . Text.Builder.toLazyText
. Text.Builder.decimal . Text.Builder.decimal
coerceInputLiteral (In.EnumBaseType type') (Enum enumValue)
| member enumValue type' = Just $ Enum enumValue
where
member value (EnumType _ _ members) = Set.member value members
coerceInputLiteral (In.InputObjectBaseType type') (Object values) =
let (In.InputObjectType _ _ inputFields) = type'
in Object
<$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
where
matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) =
matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue
coerceInputLiteral _ _ = Nothing

View File

@ -19,17 +19,23 @@ import Data.Sequence (Seq(..))
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document (Name) import Language.GraphQL.AST.Core
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Transform import Language.GraphQL.Execute.Transform
import Language.GraphQL.Trans import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a) resolveFieldValue :: Monad m
resolveFieldValue result (Field _ _ args _) = => Definition.Value
flip runReaderT (Context {arguments=args, values=result}) -> Definition.Subs
-> ActionT m a
-> m (Either Text a)
resolveFieldValue result args =
flip runReaderT (Context {arguments = Arguments args, values = result})
. runExceptT . runExceptT
. runActionT . runActionT
@ -54,10 +60,10 @@ aliasOrName (Field alias name _ _) = fromMaybe name alias
resolveAbstractType :: Monad m resolveAbstractType :: Monad m
=> AbstractType m => AbstractType m
-> HashMap Name Value -> HashMap Name Definition.Value
-> CollectErrsT m (Maybe (Out.ObjectType m)) -> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values' resolveAbstractType abstractType values'
| Just (String typeName) <- HashMap.lookup "__typename" values' = do | Just (Definition.String typeName) <- HashMap.lookup "__typename" values' = do
types' <- gets types types' <- gets types
case HashMap.lookup typeName types' of case HashMap.lookup typeName types' of
Just (ObjectType objectType) -> Just (ObjectType objectType) ->
@ -97,40 +103,44 @@ instanceOf objectType (AbstractUnionType unionType) =
in acc || this == that in acc || this == that
executeField :: Monad m executeField :: Monad m
=> Value => Definition.Value
-> Out.Resolver m -> Out.Resolver m
-> Field m -> Field m
-> CollectErrsT m Aeson.Value -> CollectErrsT m Aeson.Value
executeField prev (Out.Resolver fieldDefinition resolver) field = do executeField prev (Out.Resolver fieldDefinition resolver) field = do
let Out.Field _ fieldType _ = fieldDefinition let Out.Field _ fieldType argumentDefinitions = fieldDefinition
answer <- lift $ resolveFieldValue prev field resolver let Field _ _ arguments' _ = field
case answer of case coerceArgumentValues argumentDefinitions arguments' of
Right result -> completeValue fieldType field result Nothing -> errmsg "Argument coercing failed."
Left errorMessage -> errmsg errorMessage Just argumentValues -> do
answer <- lift $ resolveFieldValue prev argumentValues resolver
case answer of
Right result -> completeValue fieldType field result
Left errorMessage -> errmsg errorMessage
completeValue :: Monad m completeValue :: Monad m
=> Out.Type m => Out.Type m
-> Field m -> Field m
-> Value -> Definition.Value
-> CollectErrsT m Aeson.Value -> CollectErrsT m Aeson.Value
completeValue _ _ Null = pure Aeson.Null completeValue _ _ Definition.Null = pure Aeson.Null
completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer completeValue _ _ (Definition.Int integer) = pure $ Aeson.toJSON integer
completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean' completeValue _ _ (Definition.Boolean boolean') = pure $ Aeson.Bool boolean'
completeValue _ _ (Float float') = pure $ Aeson.toJSON float' completeValue _ _ (Definition.Float float') = pure $ Aeson.toJSON float'
completeValue _ _ (Enum enum) = pure $ Aeson.String enum completeValue _ _ (Definition.Enum enum) = pure $ Aeson.String enum
completeValue _ _ (String string') = pure $ Aeson.String string' completeValue _ _ (Definition.String string') = pure $ Aeson.String string'
completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result = completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
executeSelectionSet result objectType seqSelection executeSelectionSet result objectType seqSelection
completeValue (Out.ListBaseType listType) selectionField (List list) = completeValue (Out.ListBaseType listType) selectionField (Definition.List list) =
Aeson.toJSON <$> traverse (completeValue listType selectionField) list Aeson.toJSON <$> traverse (completeValue listType selectionField) list
completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result
| Object objectMap <- result = do | Definition.Object objectMap <- result = do
abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap
case abstractType of case abstractType of
Just objectType -> executeSelectionSet result objectType seqSelection Just objectType -> executeSelectionSet result objectType seqSelection
Nothing -> errmsg "Value completion failed." Nothing -> errmsg "Value completion failed."
completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result
| Object objectMap <- result = do | Definition.Object objectMap <- result = do
abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
case abstractType of case abstractType of
Just objectType -> executeSelectionSet result objectType seqSelection Just objectType -> executeSelectionSet result objectType seqSelection
@ -144,7 +154,7 @@ errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
-- to each 'Selection'. Resolves into a value containing the resolved -- to each 'Selection'. Resolves into a value containing the resolved
-- 'Selection', or a null value and error information. -- 'Selection', or a null value and error information.
executeSelectionSet :: Monad m executeSelectionSet :: Monad m
=> Value => Definition.Value
-> Out.ObjectType m -> Out.ObjectType m
-> Seq (Selection m) -> Seq (Selection m)
-> CollectErrsT m Aeson.Value -> CollectErrsT m Aeson.Value
@ -161,3 +171,38 @@ executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selection
| Just typeField <- lookupResolver name = | Just typeField <- lookupResolver name =
executeField result typeField fld executeField result typeField fld
| otherwise = errmsg $ Text.unwords ["field", name, "not resolved."] | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
coerceArgumentValues
:: HashMap Name In.Argument
-> HashMap Name Input
-> Maybe Definition.Subs
coerceArgumentValues argumentDefinitions argumentValues =
HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
where
forEach variableName (In.Argument _ variableType defaultValue) =
matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue
coerceArgumentValue inputType (Int integer) =
coerceInputLiteral inputType (Definition.Int integer)
coerceArgumentValue inputType (Boolean boolean) =
coerceInputLiteral inputType (Definition.Boolean boolean)
coerceArgumentValue inputType (String string) =
coerceInputLiteral inputType (Definition.String string)
coerceArgumentValue inputType (Float float) =
coerceInputLiteral inputType (Definition.Float float)
coerceArgumentValue inputType (Enum enum) =
coerceInputLiteral inputType (Definition.Enum enum)
coerceArgumentValue inputType Null
| In.isNonNullType inputType = Nothing
| otherwise = coerceInputLiteral inputType Definition.Null
coerceArgumentValue (In.ListBaseType inputType) (List list) =
let coerceItem = coerceInputLiteral inputType
in Definition.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Object object)
| In.InputObjectType _ _ inputFields <- inputType =
let go = forEachField object
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
in Definition.Object <$> resultMap
coerceArgumentValue _ (Variable variable) = pure variable
coerceArgumentValue _ _ = Nothing
forEachField object variableName (In.InputField _ variableType defaultValue) =
matchFieldValues coerceArgumentValue object variableName variableType defaultValue

View File

@ -18,11 +18,12 @@
-- the original AST. -- the original AST.
module Language.GraphQL.Execute.Transform module Language.GraphQL.Execute.Transform
( Document(..) ( Document(..)
, Fragment(..)
, QueryError(..)
, Operation(..)
, Selection(..)
, Field(..) , Field(..)
, Fragment(..)
, Input(..)
, Operation(..)
, QueryError(..)
, Selection(..)
, document , document
, queryError , queryError
) where ) where
@ -34,6 +35,7 @@ import Data.Foldable (find)
import Data.Functor.Identity (Identity(..)) import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Int (Int32)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
@ -43,19 +45,18 @@ import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST as Full
import Language.GraphQL.AST.Core import Language.GraphQL.AST.Core
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Directive (Directive(..))
import qualified Language.GraphQL.Type.Directive as Directive import qualified Language.GraphQL.Type.Directive as Directive
import Language.GraphQL.Type.Definition (Subs, Value(..)) import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.AST.Core as Core
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Directive as Core
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
-- | Associates a fragment name with a list of 'Core.Field's. -- | Associates a fragment name with a list of 'Field's.
data Replacement m = Replacement data Replacement m = Replacement
{ fragments :: HashMap Full.Name (Fragment m) { fragments :: HashMap Full.Name (Fragment m)
, fragmentDefinitions :: FragmentDefinitions , fragmentDefinitions :: FragmentDefinitions
, variableValues :: Subs , variableValues :: Definition.Subs
, types :: HashMap Full.Name (Type m) , types :: HashMap Full.Name (Type m)
} }
@ -78,7 +79,8 @@ data Operation m
| Mutation (Maybe Text) (Seq (Selection m)) | Mutation (Maybe Text) (Seq (Selection m))
-- | Single GraphQL field. -- | Single GraphQL field.
data Field m = Field (Maybe Full.Name) Full.Name Arguments (Seq (Selection m)) data Field m = Field
(Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
-- | Contains the operation to be executed along with its root type. -- | Contains the operation to be executed along with its root type.
data Document m = Document data Document m = Document
@ -100,6 +102,18 @@ data QueryError
| EmptyDocument | EmptyDocument
| UnsupportedRootOperation | UnsupportedRootOperation
data Input
= Int Int32
| Float Double
| String Text
| Boolean Bool
| Null
| Enum Name
| List [Definition.Value]
| Object (HashMap Name Input)
| Variable Definition.Value
deriving (Eq, Show)
queryError :: QueryError -> Text queryError :: QueryError -> Text
queryError (OperationNotFound operationName) = Text.unwords queryError (OperationNotFound operationName) = Text.unwords
["Operation", operationName, "couldn't be found in the document."] ["Operation", operationName, "couldn't be found in the document."]
@ -158,41 +172,33 @@ coerceVariableValues :: VariableValue a
. HashMap Full.Name (Type m) . HashMap Full.Name (Type m)
-> OperationDefinition -> OperationDefinition
-> HashMap.HashMap Full.Name a -> HashMap.HashMap Full.Name a
-> Either QueryError Subs -> Either QueryError Definition.Subs
coerceVariableValues types operationDefinition variableValues' = coerceVariableValues types operationDefinition variableValues =
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
in maybe (Left CoercionError) Right in maybe (Left CoercionError) Right
$ foldr coerceValue (Just HashMap.empty) variableDefinitions $ foldr forEach (Just HashMap.empty) variableDefinitions
where where
coerceValue variableDefinition coercedValues = do forEach variableDefinition coercedValues = do
let Full.VariableDefinition variableName variableTypeName defaultValue = let Full.VariableDefinition variableName variableTypeName defaultValue =
variableDefinition variableDefinition
let defaultValue' = constValue <$> defaultValue let defaultValue' = constValue <$> defaultValue
let value' = HashMap.lookup variableName variableValues'
variableType <- lookupInputType variableTypeName types variableType <- lookupInputType variableTypeName types
HashMap.insert variableName
<$> choose value' defaultValue' variableType
<*> coercedValues
choose Nothing defaultValue variableType
| Just _ <- defaultValue = defaultValue
| not (In.isNonNullType variableType) = Just Null
choose (Just value') _ variableType
| Just coercedValue <- coerceVariableValue variableType value'
, not (In.isNonNullType variableType) || coercedValue /= Null =
Just coercedValue
choose _ _ _ = Nothing
constValue :: Full.ConstValue -> Value matchFieldValues coerceVariableValue' variableValues variableName variableType defaultValue' coercedValues
constValue (Full.ConstInt i) = Int i coerceVariableValue' variableType value'
constValue (Full.ConstFloat f) = Float f = coerceVariableValue variableType value'
constValue (Full.ConstString x) = String x >>= coerceInputLiteral variableType
constValue (Full.ConstBoolean b) = Boolean b
constValue Full.ConstNull = Null constValue :: Full.ConstValue -> Definition.Value
constValue (Full.ConstEnum e) = Enum e constValue (Full.ConstInt i) = Definition.Int i
constValue (Full.ConstList l) = List $ constValue <$> l constValue (Full.ConstFloat f) = Definition.Float f
constValue (Full.ConstString x) = Definition.String x
constValue (Full.ConstBoolean b) = Definition.Boolean b
constValue Full.ConstNull = Definition.Null
constValue (Full.ConstEnum e) = Definition.Enum e
constValue (Full.ConstList l) = Definition.List $ constValue <$> l
constValue (Full.ConstObject o) = constValue (Full.ConstObject o) =
Object $ HashMap.fromList $ constObjectField <$> o Definition.Object $ HashMap.fromList $ constObjectField <$> o
where where
constObjectField (Full.ObjectField key value') = (key, constValue value') constObjectField (Full.ObjectField key value') = (key, constValue value')
@ -271,11 +277,15 @@ selection
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) -> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
selection (Full.Field alias name arguments' directives' selections) = selection (Full.Field alias name arguments' directives' selections) =
maybe (Left mempty) (Right . SelectionField) <$> do maybe (Left mempty) (Right . SelectionField) <$> do
fieldArguments <- arguments arguments' fieldArguments <- foldM go HashMap.empty arguments'
fieldSelections <- appendSelection selections fieldSelections <- appendSelection selections
fieldDirectives <- Directive.selection <$> directives directives' fieldDirectives <- Directive.selection <$> directives directives'
let field' = Field alias name fieldArguments fieldSelections let field' = Field alias name fieldArguments fieldSelections
pure $ field' <$ fieldDirectives pure $ field' <$ fieldDirectives
where
go arguments (Full.Argument name' value') =
inputField arguments name' value'
selection (Full.FragmentSpread name directives') = selection (Full.FragmentSpread name directives') =
maybe (Left mempty) (Right . SelectionFragment) <$> do maybe (Left mempty) (Right . SelectionFragment) <$> do
spreadDirectives <- Directive.selection <$> directives directives' spreadDirectives <- Directive.selection <$> directives directives'
@ -320,11 +330,15 @@ appendSelection = foldM go mempty
append acc (Left list) = list >< acc append acc (Left list) = list >< acc
append acc (Right one) = one <| acc append acc (Right one) = one <| acc
directives :: [Full.Directive] -> State (Replacement m) [Core.Directive] directives :: [Full.Directive] -> State (Replacement m) [Directive]
directives = traverse directive directives = traverse directive
where where
directive (Full.Directive directiveName directiveArguments) = directive (Full.Directive directiveName directiveArguments)
Core.Directive directiveName <$> arguments directiveArguments = Directive directiveName . Arguments
<$> foldM go HashMap.empty directiveArguments
go arguments (Full.Argument name value') = do
substitutedValue <- value value'
return $ HashMap.insert name substitutedValue arguments
-- * Fragment replacement -- * Fragment replacement
@ -371,27 +385,45 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
let newFragments = HashMap.insert name newValue fragments let newFragments = HashMap.insert name newValue fragments
in replacement{ fragments = newFragments } in replacement{ fragments = newFragments }
arguments :: [Full.Argument] -> State (Replacement m) Core.Arguments value :: forall m. Full.Value -> State (Replacement m) Definition.Value
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 :: Full.Value -> State (Replacement m) Value
value (Full.Variable name) = value (Full.Variable name) =
gets $ fromMaybe Null . HashMap.lookup name . variableValues gets (fromMaybe Definition.Null . HashMap.lookup name . variableValues)
value (Full.Int i) = pure $ Int i value (Full.Int i) = pure $ Definition.Int i
value (Full.Float f) = pure $ Float f value (Full.Float f) = pure $ Definition.Float f
value (Full.String x) = pure $ String x value (Full.String x) = pure $ Definition.String x
value (Full.Boolean b) = pure $ Boolean b value (Full.Boolean b) = pure $ Definition.Boolean b
value Full.Null = pure Null value Full.Null = pure Definition.Null
value (Full.Enum e) = pure $ Enum e value (Full.Enum e) = pure $ Definition.Enum e
value (Full.List l) = List <$> traverse value l value (Full.List l) = Definition.List <$> traverse value l
value (Full.Object o) = value (Full.Object o) =
Object . HashMap.fromList <$> traverse objectField o Definition.Object . HashMap.fromList <$> traverse objectField o
where
objectField (Full.ObjectField name value') = (name,) <$> value value'
objectField input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
:: Full.ObjectField Full.Value input (Full.Variable name) =
-> State (Replacement m) (Full.Name, Value) gets (fmap Variable . HashMap.lookup name . variableValues)
objectField (Full.ObjectField name value') = (name,) <$> value value' input (Full.Int i) = pure $ pure $ Int i
input (Full.Float f) = pure $ pure $ Float f
input (Full.String x) = pure $ pure $ String x
input (Full.Boolean b) = pure $ pure $ Boolean b
input Full.Null = pure $ pure Null
input (Full.Enum e) = pure $ pure $ Enum e
input (Full.List list) = pure . List <$> traverse value list
input (Full.Object object) = do
objectFields <- foldM objectField HashMap.empty object
pure $ pure $ Object objectFields
where
objectField resultMap (Full.ObjectField name value') =
inputField resultMap name value'
inputField :: forall m
. HashMap Full.Name Input
-> Full.Name
-> Full.Value
-> State (Replacement m) (HashMap Full.Name Input)
inputField resultMap name value' = do
objectFieldValue <- input value'
case objectFieldValue of
Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap
Nothing -> pure resultMap

View File

@ -6,12 +6,10 @@ module Language.GraphQL.Execute.CoerceSpec
import Data.Aeson as Aeson ((.=)) import Data.Aeson as Aeson ((.=))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson import qualified Data.Aeson.Types as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (isNothing) import Data.Maybe (isNothing)
import Data.Scientific (scientific) import Data.Scientific (scientific)
import qualified Data.Set as Set import qualified Data.Set as Set
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
@ -22,14 +20,6 @@ direction :: EnumType
direction = EnumType "Direction" Nothing direction = EnumType "Direction" Nothing
$ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"] $ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"]
coerceInputLiteral :: In.Type -> Value -> Maybe Subs
coerceInputLiteral input value = coerceInputLiterals
(HashMap.singleton "variableName" input)
(HashMap.singleton "variableName" value)
lookupActual :: Maybe (HashMap Name Value) -> Maybe Value
lookupActual = (HashMap.lookup "variableName" =<<)
singletonInputObject :: In.Type singletonInputObject :: In.Type
singletonInputObject = In.NamedInputObjectType type' singletonInputObject = In.NamedInputObjectType type'
where where
@ -39,7 +29,7 @@ singletonInputObject = In.NamedInputObjectType type'
spec :: Spec spec :: Spec
spec = do spec = do
describe "ToGraphQL Aeson" $ do describe "VariableValue Aeson" $ do
it "coerces strings" $ it "coerces strings" $
let expected = Just (String "asdf") let expected = Just (String "asdf")
actual = coerceVariableValue actual = coerceVariableValue
@ -107,7 +97,7 @@ spec = do
let expected = Just (Enum "NORTH") let expected = Just (Enum "NORTH")
actual = coerceInputLiteral actual = coerceInputLiteral
(In.NamedEnumType direction) (Enum "NORTH") (In.NamedEnumType direction) (Enum "NORTH")
in lookupActual actual `shouldBe` expected in actual `shouldBe` expected
it "fails with non-existing enum value" $ it "fails with non-existing enum value" $
let actual = coerceInputLiteral let actual = coerceInputLiteral
(In.NamedEnumType direction) (Enum "NORTH_EAST") (In.NamedEnumType direction) (Enum "NORTH_EAST")
@ -115,4 +105,4 @@ spec = do
it "coerces integers to IDs" $ it "coerces integers to IDs" $
let expected = Just (String "1234") let expected = Just (String "1234")
actual = coerceInputLiteral (In.NamedScalarType id) (Int 1234) actual = coerceInputLiteral (In.NamedScalarType id) (Int 1234)
in lookupActual actual `shouldBe` expected in actual `shouldBe` expected

View File

@ -11,10 +11,12 @@ import Data.Functor.Identity (Identity)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Set as Set
import Language.GraphQL.Trans import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema (Schema(..))
import Test.StarWars.Data import Test.StarWars.Data
import Prelude hiding (id) import Prelude hiding (id)
@ -24,10 +26,17 @@ schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing } schema = Schema { query = queryType, mutation = Nothing }
where where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) hero) [ ("hero", Out.Resolver heroField hero)
, ("human", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) human) , ("human", Out.Resolver humanField human)
, ("droid", Out.Resolver (Out.Field Nothing (Out.NamedObjectType droidObject) mempty) droid) , ("droid", Out.Resolver droidField droid)
] ]
heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "episode"
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "id"
$ In.Argument Nothing (In.NonNullScalarType string) Nothing
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
heroObject :: Out.ObjectType Identity heroObject :: Out.ObjectType Identity
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
@ -76,6 +85,10 @@ idField f = do
let (Object v') = v let (Object v') = v
pure $ v' HashMap.! f pure $ v' HashMap.! f
episodeEnum :: EnumType
episodeEnum = EnumType "Episode" Nothing
$ Set.fromList ["NEW_HOPE", "EMPIRE", "JEDI"]
hero :: ActionT Identity Value hero :: ActionT Identity Value
hero = do hero = do
episode <- argument "episode" episode <- argument "episode"