From 4c9264c12c15d52e40a245b21acaa70f76cc9ba4 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 6 Jun 2020 21:22:11 +0200 Subject: [PATCH] Coerce argument values properly Fixes #44. --- CHANGELOG.md | 2 + src/Language/GraphQL/Execute/Coerce.hs | 125 ++++++++------- src/Language/GraphQL/Execute/Execution.hs | 93 ++++++++--- src/Language/GraphQL/Execute/Transform.hs | 154 +++++++++++-------- tests/Language/GraphQL/Execute/CoerceSpec.hs | 16 +- tests/Test/StarWars/Schema.hs | 21 ++- 6 files changed, 251 insertions(+), 160 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e98fd5b..f7bcf4d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,8 @@ and this project adheres to - AST transformation should never fail. * Missing variable are assumed to be null. * Invalid (recusrive or non-existing) fragments should be skipped. +- Argument value coercion. +- Variable value coercion. ### Changed - `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 09375fd..ab4099c 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -1,20 +1,22 @@ +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} -- | Types and functions used for input and result coercion. module Language.GraphQL.Execute.Coerce ( VariableValue(..) - , coerceInputLiterals + , coerceInputLiteral + , matchFieldValues ) where import qualified Data.Aeson as Aeson import Data.HashMap.Strict (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.Builder 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 Language.GraphQL.AST.Document (Name) +import Language.GraphQL.AST.Core import qualified Language.GraphQL.Type.In as In import Language.GraphQL.Type.Definition @@ -67,10 +69,10 @@ instance VariableValue Aeson.Value where then Just $ Object resultMap else Nothing where - foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues + foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues' $ Just (objectValue, HashMap.empty) - matchFieldValues _ _ Nothing = Nothing - matchFieldValues fieldName inputField (Just (objectValue, resultMap)) = + matchFieldValues' _ _ Nothing = Nothing + matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) = let (In.InputField _ fieldType _) = inputField insert = flip (HashMap.insert fieldName) resultMap newObjectValue = HashMap.delete fieldName objectValue @@ -90,60 +92,67 @@ instance VariableValue Aeson.Value where pure $ coerced : list coerceVariableValue _ _ = Nothing --- | Coerces operation arguments according to the input coercion rules for the --- corresponding types. -coerceInputLiterals - :: HashMap Name In.Type - -> HashMap Name Value - -> Maybe Subs -coerceInputLiterals variableTypes variableValues = - foldWithKey operator variableTypes +-- | Looks up a value by name in the given map, coerces it and inserts into the +-- result map. If the coercion fails, returns 'Nothing'. If the value isn't +-- given, but a default value is known, inserts the default value into the +-- result map. Otherwise it fails with 'Nothing' if the Input Type is a +-- Non-Nullable type, or returns the unchanged, original map. +matchFieldValues :: forall a + . (In.Type -> a -> Maybe Value) + -> 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 - 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 . Text.Lazy.toStrict . Text.Builder.toLazyText . 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 diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 140df81..8a3f400 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -19,17 +19,23 @@ import Data.Sequence (Seq(..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Sequence as Seq -import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.AST.Core import Language.GraphQL.Error +import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Transform 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 Language.GraphQL.Type.Schema -resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a) -resolveFieldValue result (Field _ _ args _) = - flip runReaderT (Context {arguments=args, values=result}) +resolveFieldValue :: Monad m + => Definition.Value + -> Definition.Subs + -> ActionT m a + -> m (Either Text a) +resolveFieldValue result args = + flip runReaderT (Context {arguments = Arguments args, values = result}) . runExceptT . runActionT @@ -54,10 +60,10 @@ aliasOrName (Field alias name _ _) = fromMaybe name alias resolveAbstractType :: Monad m => AbstractType m - -> HashMap Name Value + -> HashMap Name Definition.Value -> CollectErrsT m (Maybe (Out.ObjectType m)) resolveAbstractType abstractType values' - | Just (String typeName) <- HashMap.lookup "__typename" values' = do + | Just (Definition.String typeName) <- HashMap.lookup "__typename" values' = do types' <- gets types case HashMap.lookup typeName types' of Just (ObjectType objectType) -> @@ -97,40 +103,44 @@ instanceOf objectType (AbstractUnionType unionType) = in acc || this == that executeField :: Monad m - => Value + => Definition.Value -> Out.Resolver m -> Field m -> CollectErrsT m Aeson.Value executeField prev (Out.Resolver fieldDefinition resolver) field = do - let Out.Field _ fieldType _ = fieldDefinition - answer <- lift $ resolveFieldValue prev field resolver - case answer of - Right result -> completeValue fieldType field result - Left errorMessage -> errmsg errorMessage + let Out.Field _ fieldType argumentDefinitions = fieldDefinition + let Field _ _ arguments' _ = field + 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 + Left errorMessage -> errmsg errorMessage completeValue :: Monad m => Out.Type m -> Field m - -> Value + -> Definition.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 _ _ Definition.Null = pure Aeson.Null +completeValue _ _ (Definition.Int integer) = pure $ Aeson.toJSON integer +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 (List list) = +completeValue (Out.ListBaseType listType) selectionField (Definition.List list) = Aeson.toJSON <$> traverse (completeValue listType selectionField) list completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result - | Object objectMap <- result = do + | Definition.Object objectMap <- result = do abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap case abstractType of Just objectType -> executeSelectionSet result objectType seqSelection Nothing -> errmsg "Value completion failed." completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result - | Object objectMap <- result = do + | Definition.Object objectMap <- result = do abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap case abstractType of 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 -- 'Selection', or a null value and error information. executeSelectionSet :: Monad m - => Value + => Definition.Value -> Out.ObjectType m -> Seq (Selection m) -> CollectErrsT m Aeson.Value @@ -161,3 +171,38 @@ executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selection | Just typeField <- lookupResolver name = executeField result typeField fld | 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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index fe517d9..8364105 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -18,11 +18,12 @@ -- the original AST. module Language.GraphQL.Execute.Transform ( Document(..) - , Fragment(..) - , QueryError(..) - , Operation(..) - , Selection(..) , Field(..) + , Fragment(..) + , Input(..) + , Operation(..) + , QueryError(..) + , Selection(..) , document , queryError ) where @@ -34,6 +35,7 @@ import Data.Foldable (find) import Data.Functor.Identity (Identity(..)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int32) import Data.Maybe (fromMaybe) import Data.List.NonEmpty (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 Language.GraphQL.AST.Core import Language.GraphQL.Execute.Coerce +import Language.GraphQL.Type.Directive (Directive(..)) 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.Definition as Definition 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. +-- | Associates a fragment name with a list of 'Field's. data Replacement m = Replacement { fragments :: HashMap Full.Name (Fragment m) , fragmentDefinitions :: FragmentDefinitions - , variableValues :: Subs + , variableValues :: Definition.Subs , types :: HashMap Full.Name (Type m) } @@ -78,7 +79,8 @@ data Operation m | Mutation (Maybe Text) (Seq (Selection m)) -- | 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. data Document m = Document @@ -100,6 +102,18 @@ data QueryError | EmptyDocument | 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 (OperationNotFound operationName) = Text.unwords ["Operation", operationName, "couldn't be found in the document."] @@ -158,41 +172,33 @@ coerceVariableValues :: VariableValue a . HashMap Full.Name (Type m) -> OperationDefinition -> HashMap.HashMap Full.Name a - -> Either QueryError Subs -coerceVariableValues types operationDefinition variableValues' = + -> Either QueryError Definition.Subs +coerceVariableValues types operationDefinition variableValues = let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition in maybe (Left CoercionError) Right - $ foldr coerceValue (Just HashMap.empty) variableDefinitions + $ foldr forEach (Just HashMap.empty) variableDefinitions where - coerceValue variableDefinition coercedValues = do + forEach variableDefinition coercedValues = do let Full.VariableDefinition variableName variableTypeName defaultValue = variableDefinition let defaultValue' = constValue <$> defaultValue - let value' = HashMap.lookup variableName variableValues' - 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 -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 + matchFieldValues coerceVariableValue' variableValues variableName variableType defaultValue' coercedValues + coerceVariableValue' variableType value' + = coerceVariableValue variableType value' + >>= coerceInputLiteral variableType + +constValue :: Full.ConstValue -> Definition.Value +constValue (Full.ConstInt i) = Definition.Int i +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) = - Object $ HashMap.fromList $ constObjectField <$> o + Definition.Object $ HashMap.fromList $ constObjectField <$> o where constObjectField (Full.ObjectField key value') = (key, constValue value') @@ -271,11 +277,15 @@ 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' + fieldArguments <- foldM go HashMap.empty arguments' fieldSelections <- appendSelection selections fieldDirectives <- Directive.selection <$> directives directives' let field' = Field alias name fieldArguments fieldSelections pure $ field' <$ fieldDirectives + where + go arguments (Full.Argument name' value') = + inputField arguments name' value' + selection (Full.FragmentSpread name directives') = maybe (Left mempty) (Right . SelectionFragment) <$> do spreadDirectives <- Directive.selection <$> directives directives' @@ -320,11 +330,15 @@ appendSelection = foldM go mempty append acc (Left list) = list >< 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 where - directive (Full.Directive directiveName directiveArguments) = - Core.Directive directiveName <$> arguments directiveArguments + directive (Full.Directive directiveName 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 @@ -371,27 +385,45 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do let newFragments = HashMap.insert name newValue fragments in replacement{ fragments = newFragments } -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 :: Full.Value -> State (Replacement m) Value +value :: forall m. Full.Value -> State (Replacement m) Definition.Value value (Full.Variable name) = - 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 + gets (fromMaybe Definition.Null . HashMap.lookup name . variableValues) +value (Full.Int i) = pure $ Definition.Int i +value (Full.Float f) = pure $ Definition.Float f +value (Full.String x) = pure $ Definition.String x +value (Full.Boolean b) = pure $ Definition.Boolean b +value Full.Null = pure Definition.Null +value (Full.Enum e) = pure $ Definition.Enum e +value (Full.List l) = Definition.List <$> traverse value l 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 - :: Full.ObjectField Full.Value - -> State (Replacement m) (Full.Name, Value) -objectField (Full.ObjectField name value') = (name,) <$> value value' +input :: forall m. Full.Value -> State (Replacement m) (Maybe Input) +input (Full.Variable name) = + gets (fmap Variable . HashMap.lookup name . variableValues) +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 diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs index ed8fd63..15180fb 100644 --- a/tests/Language/GraphQL/Execute/CoerceSpec.hs +++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs @@ -6,12 +6,10 @@ module Language.GraphQL.Execute.CoerceSpec import Data.Aeson as Aeson ((.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import Data.HashMap.Strict (HashMap) 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.Document (Name) import Language.GraphQL.Execute.Coerce import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.In as In @@ -22,14 +20,6 @@ direction :: EnumType direction = EnumType "Direction" Nothing $ 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.NamedInputObjectType type' where @@ -39,7 +29,7 @@ singletonInputObject = In.NamedInputObjectType type' spec :: Spec spec = do - describe "ToGraphQL Aeson" $ do + describe "VariableValue Aeson" $ do it "coerces strings" $ let expected = Just (String "asdf") actual = coerceVariableValue @@ -107,7 +97,7 @@ spec = do let expected = Just (Enum "NORTH") actual = coerceInputLiteral (In.NamedEnumType direction) (Enum "NORTH") - in lookupActual actual `shouldBe` expected + in actual `shouldBe` expected it "fails with non-existing enum value" $ let actual = coerceInputLiteral (In.NamedEnumType direction) (Enum "NORTH_EAST") @@ -115,4 +105,4 @@ spec = do it "coerces integers to IDs" $ let expected = Just (String "1234") actual = coerceInputLiteral (In.NamedScalarType id) (Int 1234) - in lookupActual actual `shouldBe` expected + in actual `shouldBe` expected diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index b30da1a..d787a07 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -11,10 +11,12 @@ import Data.Functor.Identity (Identity) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (catMaybes) import Data.Text (Text) +import qualified Data.Set as Set 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 Language.GraphQL.Type.Schema (Schema(..)) import Test.StarWars.Data import Prelude hiding (id) @@ -24,10 +26,17 @@ schema :: Schema Identity schema = Schema { query = queryType, mutation = Nothing } where queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList - [ ("hero", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) hero) - , ("human", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) human) - , ("droid", Out.Resolver (Out.Field Nothing (Out.NamedObjectType droidObject) mempty) droid) + [ ("hero", Out.Resolver heroField hero) + , ("human", Out.Resolver humanField human) + , ("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 "Human" Nothing [] $ HashMap.fromList @@ -76,6 +85,10 @@ idField f = do let (Object v') = v pure $ v' HashMap.! f +episodeEnum :: EnumType +episodeEnum = EnumType "Episode" Nothing + $ Set.fromList ["NEW_HOPE", "EMPIRE", "JEDI"] + hero :: ActionT Identity Value hero = do episode <- argument "episode"